#! /bin/env tclsh
package require {ycl coro relay}
namespace import [yclprefix]::coro::relay
package require {ycl shelf shelf}
namespace import [yclprefix]::shelf::shelf
shelf spawn machine
namespace eval doc {}
variable doc::machine {
description {
A "machine" object provides a mechanism to connect to and communicate
with a machine which , in this case , is another process in which a Tcl
interpreter is listening on stdin for commands .
}
}
machine eval {
package require {ycl chan interp interp}
namespace import [yclprefix]::chan::interp::interp
rename interp rinterp
namespace import [yclprefix]::coro::relay
proc init _ {
namespace upvar $_ sending sending sendqueue sendqueue
coroutine ${_}::send $_ send_coro
set sending 0
set sendqueue {}
coroutine ${_}::send_interp $_ rinterp_coro
return $_
}
proc connect _ {
relay order 0 [coroutine ${_}::connection ::apply [list _ {
namespace upvar $_ chan chan
namespace upvar $_ interp interp
relay accept deliver [info coroutine]
if {![
catch {
set chan [::open |[
::list [::info nameofexecutable] - 2>@stderr] r+]
} cres copts
]} {
catch {
set interp [[rinterp spawn ${_}::interp1_[info cmdcount]] init $chan]
} cres copts
}
{*}$deliver $cres $copts
} [namespace current]] $_]
}
proc disconnect _ {
namespace upvar $_ chan chan interp interp
close [$_ $ chan]
unset chan
unset interp
}
proc rinterp_coro {_} {
namespace upvar $_ sending sending sendqueue sendqueue
set sending 1
while 1 {
while {[llength $sendqueue]} {
set sendqueue [lassign $sendqueue[set sendqueue {}] script deliver]
set result [[$_ $ interp] send $script]
{*}$deliver $result
}
set sending 0
yield
}
}
proc send_coro _ {
namespace upvar $_ sending sending sendqueue sendqueue
while 1 {
relay accept {deliver script}
# {ycl chan interp interp send} expect to be in a coroutine it can
# yield from
lappend sendqueue $script $deliver
if {!$sending} {
$_ send_interp
}
}
}
}
machine method connect
machine subcmd connection
machine method disconnect
machine subcmd send
machine method send_coro
machine subcmd send_interp
machine method rinterp_coro
#### Demo ####
variable doc::main {
description {
Spins up $count machines and communicates with them
}
}
coroutine main apply [list {} {
set count 5
set connections {}
for {set i 0} {$i < $count} {incr i} {
set machine m$i
lappend machines $machine
[machine spawn $machine] init
lappend connections [m$i connect]
}
# Wait until all connections are complete
foreach connection $connections {
relay receive orders $connection
}
set orders {}
set i 0
foreach machine $machines {
relay order 0 $machine send [list set a $i]
dict set orders [relay order 0 $machine send {expr {$a * 3}}] $machine
incr i
}
# To receive results in any order
while {[llength [dict keys $orders]]} {
# Receive all orders to raise any errors, even if the result is
# discarded here.
set result [relay receive]
if {[relay last] in $orders} {
dict set results [dict get $orders [relay last]] $result
}
dict unset orders [relay last]
}
puts [list results $results]
# To receive results in a particular order
set orders {}
set i 0
foreach machine $machines {
dict set orders $i order [relay order 0 $machine send {expr {$a * 5}}]
dict set orders $i machine $machine
incr i
}
foreach key [dict keys $orders] {
dict set results2 [dict get $orders $key machine] [
relay receive orders [dict get $orders $key order]]
}
puts [list results2 $results2]
foreach machine $machines {
$machine disconnect
}
# This returns the error result, "disconnected"
catch {m1 send {lindex hello}} res options
# This is an error message
puts [list message $res]
exit [dict get $options -code]
} [namespace current]]
vwait forever