#! /bin/env tclsh
if 0 {
description {
This implementation implies a protococol in which the last message
delivered by a coroutine that accepts orders , before it ceases to
exists , is an out-of-band message in conclusion, not belonging to the
sequence of results kkk. It could be used to provide
to provide statistics about its activity during its lifetime ,
A conformant coroutine should generally reserve any producers it uses
before it yields for the first time . For example , if the coroutine
is going to be consuming from a non-blocking channel , it should
configure events on that channel prior to the first yield. Otherwise ,
when something else makes an order , the event loop may send events for
the channel somewhere else before the coroutine receives the order .
If a coroutine places an order, then ceases to exist before the order
is deliverd, and another coroutine by the same name appears in its
place, the order will be delivered to the new coroutine. If this isn't
desired, either make sure a coroutine cancels all its orders before
disappearing, or ensure that coroutines are named such that this
coroutine "shimmering" doesn't occur.
}
}
variable doc::accept {
synopsis {
accept ?spec? ?payload?
}
description {
yield until called, and return a list in which the first value is
the sender's information, and any subsequent values available the
purposes of the current coroutine.'s
}
args {
spec {
description {
a list of names to assign from the list returned by [yield] to
local variables, in the same manner as the second argument of
[proc], to local variables. If the last name is args, a list
of remaining values is assigned to it.
}
}
yield {
description {
A value to yield .
}
default {[info coroutine]}
}
}
}
proc accept args {
variable coroutines
variable orders
lassign $args spec yield
if {[llength $args] < 2} {
set yield [info coroutine]
}
if {[dict exists $coroutines [info coroutine] queue]} {
dict update coroutines [info coroutine] coroinfo {
dict update coroinfo queue queue {
dict for {id candidate} $queue {
dict unset queue $id
if {[dict exists $orders $id]} {
# Found an order that hasn't been canceled
set incoming $candidate
break
}
}
}
}
}
if {![info exists incoming]} {
set incoming [yieldto return -level 0 $yield]
if {![llength $args]} {
if {[llength $incoming] > 1} {
flush stdout
error [list {wrong # args}]
}
return [lindex $incoming 0]
}
}
set incoming [list [lindex $incoming end] {*}[lrange $incoming 0 end-1]]
set i 0
set slast [expr {[llength $spec] - 1}]
foreach key $spec val $incoming {
upvar 1 $key v_$key
if {$i == $slast} {
if {$key eq {args}} {
set v_$key [lrange $incoming $i end]
break
} elseif {[llength $incoming] > $i + 1} {
error [list {wrong # args}]
}
}
set v_$key $val
incr i
}
return $incoming
}
variable doc::call {
description {
Like [order], but the evaluated command does not have to call [accept]
or use [deliver], or even be a coroutine (although it can be). It's
just a normal command that returns a result. Returns an order id that
can passed to [cancel] .
}
args {
delay {
description {
Number of milliseconds to delay before sending evaluating the
command .
}
}
args {
description {
The command to evaluate .
}
}
}
}
proc call {delay args} {
variable coroutines
variable orders
set id [info cmdcount]
set coro [info coroutine]
dict set orders $id coro $coro
dict set coroutines $coro orders $id {}
after $delay [list after idle [list ::apply [list {ns id sender cmd} {
::catch {namespace eval $ns $cmd} res options
deliver 0 $ns $sender $id $res $options
} [namespace current]] [uplevel {namespace current}] $id [info coroutine] $args]]
return $id
}
#proc call {delay args} {
# set id [order $delay call_coro [uplevel {namespace current}] $args]
#}
#
#coroutine call_coro ::apply [list {} {
# while 1 {
# accept {deliver ns cmd}
# catch {namespace eval $ns $cmd} cres coptions
# {*}$deliver $cres $coptions
# }
#} [namespace current]]
variable doc::cancel {
description {
Cancel an order for which there hasn't been received. If the order
hasn't been started, it won't be. Otherwise, any results it delivers
are discarded .
}
}
proc cancel args {
variable coroutines
variable orders
if {[lindex $args 0] eq {coroutine}} {
set args [lassign $args[set args {}] -> coro]
set coro [uplevel [list namespace which $coro]]
} else {
set coro [info coroutine]
}
if {[lindex $args 0] eq {all}} {
set ids [dict keys [dict get $coroutines $coro orders]]
} elseif {[llength $args] == 1} {
set ids [list [lindex $args 0]]
} else {
set ids $args
}
foreach id $ids {
# This will either be an stimeout or an etimeout, but only one such
# event is scheduled at any time .
if {[dict exists $orders $id after]} {
after cancel [dict get $orders $id after]
}
dict unset orders $id
}
}
variable doc::deliver {
description {
Deliver an order .
}
args {
delay {
description {
Number of milliseconds to delay before mmaking the delivery .
}
}
sender {
A list in which the first value is the namespace in which to
evaluate a command prefix, and remaining values are the command
prefix. It is typically acquired as the first value in the list
returned by [accept] .
}
args {
description {
Expanded and passed as arguments to {*}$sender
In other words, items in the first value are expanded
in its place, and the resulting list is the command .
}
}
}
}
proc deliver {delay ns sender id args} {
if {[llength $args] > 2} {
return -code error [list {wrong # args}]
}
variable orders
if {![dict exists $orders $id]} {
# Must have been cancelled.
return
}
after $delay [list after idle [list ::apply [
list {ns sender id cmd} {
variable orders
if {![dict exists $orders $id]} {
# Must have been cancelled.
return
}
# This would only be an etimout scheduled event , as an
# stimeout event sould have been removed by [order]
if {[dict exists $orders $id after]} {
after cancel [dict get $orders $id after]
}
# The extra [list] around [lindex $sender 2] is so that calls
# targeting [receive] end in a list , just as calls targeting
# [accept] do . This allows both [accept] and [receive] to inspect the
# metadata of both [order] and [deliver] or [order] calls.
namespace eval $ns [
list $sender {*}$cmd [list $id]]
} [namespace current]] $ns $sender $id $args]]
}
variable doc::iter {
description {
Iteratively place an order to $coro and evaluate $script for each item
received. $name is a list containing the name of a variable to assign
each delivered item to, and optionally the name and initial value of a
variable containing a list of values to send as arguments of the order
. After making each order, this optional variable is reset to the empty
string .
To be compatible with this command , a coroutine must follow a protocol
in which the final delivery it makes before ceasing to exist is an
out-of-band message, not to be taken as the last value in the sequence
it produced, but rather as data in conclusion , summarizing its activity
during its lifetime . For example , the final message might present
statistics about the number of deliveries made , amount of time it
spent busy or idle , or the nature of the values it delivered .
Returns the last message received by the coroutine. It wouldn't make
sense for this command to return the last result of the evaluation of
$coro, because the loop may break before is $script is ever executed ,
creating unresolvable ambiguity between an empty string returned as the
result of the execution of $script, and an empty string returned
because the loop broke and $script never executed .
To pass arguments into the next call to $coro, $script can use [return
-code return ...]
}
}
proc iter {name coro script} {
if {[llength $name] > 1} {
lassign $name name msg
} else {
set msg {}
}
upvar $name varname
if {![info exists varname]} {
set varname {}
}
while 1 {
uplevel [list [namespace current] order 0 $coro {*}$msg]
set varname [receive]
if {[uplevel [list namespace which $coro]] eq {}} break
try {uplevel $script} on continue {tres topts} {
set msg $tres
} on return {tres topts} {
set msg $tres
}
}
return $varname
}
variable doc::last {
description {
The order id of the last delivered task .
}
}
proc last {} {
variable last
return $last
}
variable doc::order {
description {
Place a new order . and return an order id that can be passed to
[cancel] .
}
args {
delay {
Number of milliseconds to wait before placing the order . If
$delay contains more than one item , the second item is the maximum
number of milliseconds alloted for delivery , order times out,
after which the order is not be initiated if it hasn't been
started, and if it has, any subsequent deliveries are discarded .
If there is a third item, the second item is the maximum number of
milliseconds alllotted for the order to be started , and the third
item is the maximum number of milliseonds alloted for delivery . If
the completion timeout occurs before the order is complete , any
subsequent delivery is discarded .
}
}
}
proc order {delay args} {
variable coroutines
variable orders
set id [info cmdcount]
dict set orders $id coro [info coroutine]
dict set coroutines [info coroutine] orders $id {}
if {[llength $delay]} {
set delay [lassign $delay[set delay {}] afterdelay]
if {[llength $delay]} {
set delay [lassign $delay [set delay {}] stimeout]
if {[llength $delay]} {
# There is both a start timeout and an elapsed timeout
dict set orders $id after [after $stimeout [list [info coroutine] $id {} {-code 5}]]
set delay [lassign $delay[set delay {}] etimeout]
if {[llength $delay]} {
return -code error [list {wrong # args}]
}
}
dict set orders $id etimeout $stimeout
}
}
after $afterdelay [list after idle [list ::apply [list {ns id sender cmd} {
variable orders
if {[dict exists $orders $id]} {
# The task hasn't been cancelled.
if {[dict exists $orders $id etimout]} {
if {[dict exists $orders $id after]} {
after cancel [dict get $orders $id after]
}
dict set orders $id after [after [
dict get $orders $id etimeout] [
list [info coroutine] $id {} {-code 5}]]
dict unset orders $id etimeout
}
# {*}$cmd should be picked up by [accept] , which , like [receive]
# , expects the last item in the last argument to be the
# transaction id .
namespace eval $ns [list {*}$cmd [
list [namespace current] deliver 0 $ns $sender $id]]
}
} [namespace current]] [uplevel {namespace current}] $id [info coroutine] $args]]
return $id
}
variable doc::receive {
description {
Yield until a previously-placed order comes in, resume by accepting a
result and an options dictionary , and return that result and
accompanying options . In addition to the -code values specified for
[return] , 5 indicates a timeout of the order before a response was
received by the service .
}
}
proc receive {} {
variable last
variable coroutines
variable orders
while 1 {
set args [yieldto return -level 0]
set meta [lindex $args end]
set rid [lindex $meta end]
if {[dict get $orders $rid coro] ne [info coroutine]} {
# This mus be an incoming request . Queue it up for [accept]
dict set coroutines [info coroutine] queue $rid $args
continue
}
set args [lreplace $args[set args {}] end end]
# Don't check for wrong # args here since that's done in [deliver]
lassign $args[set args {}] result options
break
}
set last $rid
dict unset orders $rid
dict unset coroutines [info coroutine] orders $rid
if {[dict exists $options -code] && [dict get $options -code] == 5} {
return -code 5 [list timeout]
}
dict set options -id $rid
return -options $options $result
}
variable doc::switch {
description {
Yield until an order was received and respond to the order according to
the first word of the order .
}
args {
routes {
description {
A dictionary of words and corresponding scripts . These are
merged into the default routes .
}
}
}
}
proc switch_ args {
foreach key [dict keys $args] {
if {$key ni {routes}} {
return -code error [list {unknown argument} $key]
}
}
set args [dict merge {routes {}} $args]
dict update args routes routes {}
dict for {key val} $routes[set routes {}] {
dict set routes $key [list catch [list uplevel $val] res options]
}
# Take advantage of ordered dictionaries
if {[lindex [dict keys $routes] end] ne {default}} {
dict set routes default {
set res [list {unknown accept command} $cmd]
set options {-code error}
}
}
set cmds [dict merge [dict create \x01 {
{*}$args
} eval {
catch {uplevel $args} res options
} route {
}
] $routes]
set args [lassign [yieldto return -level 0] cmd]
set sender [lindex $args end]
set args [lrange $args[set args {}] 0 end-1]
switch $cmd $cmds
return [list {*}$sender $res $options]
}
variable doc::unregister {
description {
Release all resources allocated by this system for a particular
coroutine .
}
}
proc unregister coroutine {
variable coroutines
cancel coroutine $coroutines all
dict unset coroutines $coroutine
}
proc wrap {iter wrapper args} {
dict for {key val} $args {
if {$key in {name}} {
dict update args $key $key {}
} else {
return -code error [list {unknown argument} $key]
}
}
if {![info exists name]} {
set name [namespace current]::[info cmdcount]
}
uplevel 1 [
list coroutine $name ::apply [list {iter wrapper} {
while 1 {
relay accept {deliver args}
set order [lindex $deliver 1 end]
relay order 0 $iter {*}$args
catch {relay receive} cres copts
if {[namespace which $iter] eq {}} {
{*}$deliver $cres $copts
return
} else {
{*}$deliver {*}[{*}$wrapper $cres $copts]
}
}
} [uplevel {namespace current}]] $iter $wrapper]
return $name
}
namespace ensemble configure [namespace current] -map {
accept accept call call cancel cancel deliver deliver iter iter
last last order order receive receive switch switch_ wrap wrap
}
variable last -1
variable coroutines {}
variable orders {}