See the tcllib packages coroutine and coroutine::auto for nicely polished versions of CGM's code below.
CGM Here are quick-and-dirty versions of coroutine-enabled after, gets and vwait, with a simple test program. This uses the new coroutine facilities in tcl8.6a2.
APN I believe this, or a variant, has been folded into the coroutine module in tcllib.
CGM Yes, the tcllib coroutine module looks very like a cleaned up and expanded version of the code I originally posted here, though that's not mentioned in the source.
AK My apologies for that, I usually am good about giving attribution. Have made a note to self now to fix this.
CGM Thanks Andreas!
When run:
Note that each coroutine maintains state in its local variables, but they all run effectively in parallel.
# Helpers lifted from wiki:
proc spawn cmd {
set k [gensym]
coroutine $k {*}$cmd
}
proc gensym {{prefix "::coroutine"}} {
variable gensymid
return $prefix[incr gensymid]
}
#########################################################################
# co_after delay
# - calling coroutine pauses for (at least) delay milliseconds and then
# continues, while allowing other events to be processed in the meantime.
proc co_after ms {
after $ms [info coroutine]
yield
}
proc counter {id ms} {
set count 0
while 1 {
puts "$id [incr count]"
co_after $ms
}
}
spawn {counter A 2000}
spawn {counter {B } 3000}
spawn {counter {C } 4000}
#########################################################################
# co_gets channelId
# - calling coroutine reads a line from specified channel. If no data is
# available the coroutine waits for data, while allowing other events to
# be processed.
proc co_gets chan {
# Note: We need a loop here because even if more data became available
# on the channel it may not be a complete line. As the regular gets
# blocks until a complete line is present so must we.
set line ""
while 1 {
fileevent $chan readable [info coroutine]
yield
fileevent $chan readable {}
if {[gets $chan line] >= 0 || [eof $chan]} break
}
return $line
}
proc count_input {} {
set count 0
while 1 {
set input [co_gets stdin]
puts "INPUT LINE [incr count]: $input"
if {[string is integer -strict $input]} {
set ::trigger1 $input
} else {
set ::trigger2 $input
}
}
}
spawn count_input
#########################################################################
# co_vwait variable
# - calling coroutine waits until the named variable is set and then
# continues. Unlike standard vwait, these calls do not nest, ie.
# multiple co::vwaits wait in parallel and can be activated in any order.
proc co_vwait_callback {coro args} {$coro}
proc co_vwait varname {
upvar $varname var
set callback "co_vwait_callback [info coroutine]"
trace add variable var write $callback
yield
trace remove variable var write $callback
}
proc waiter1 {} {
set total 0
while 1 {
co_vwait ::trigger1
puts "WAITER1 TOTAL: [incr total $::trigger1]"
}
}
proc waiter2 {} {
set buffer {}
while 1 {
co_vwait ::trigger2
puts "WAITER2 BUFFER: [append buffer $::trigger2]"
}
}
spawn waiter1
spawn waiter2
#########################################################################
vwait foreverPeter Spjuth 20090903: I noticed that the coroutine waiting for the variable executed immediately when someone wrote to the variable. Thus the code writing got some strange side effects. To return to a stricter cooperative multitasking, I delayed waking the one waiting until idle time:
proc co_vwait varname {
upvar $varname var
set callback "co_vwait_callback [info coroutine]"
trace add variable var write $callback
yield
trace remove variable var write $callback
# Delay continuing until idle time, to avoid side effects in the
# code writing the variable.
after idle [info coroutine]
yield
}NEM Very nice! I particularly like co_gets: it makes non-blocking I/O just about as convenient as the blocking version.
AK I wonder, should we create a tcl::unsupported::co namespace or other where we can collect these commands ? Could allow us get rid of the 'co_' prefix. For completeness we will need a 'co_read' as well. For polish go the extra mile and make them fully API compatible to the originals. Oh, what do we get from [infoCoroutine], or [info coroutine] if there is no coroutine running ? The empty string? If we can determine whether we are in a coro or not we can implement something which switches the internal behaviour automatically. I.e. regular [gets] outside of a coro, and the coro specific gets if a coro is running. Anyone up4 it ?
(MS sez: note that [info coroutine] returns an FQN, so {} is unambiguously "not in a coroutine": a coroutine named {} returns '::')
AK: Now I have to look at my own pop3 retriever code again, which is fully event-based, and quite difficult to follow. Especially the highlevel control code pulling one message after the other and handling any errors which occur. Inverting that loop into an event chain was murder when I did it a few years ago. As a coro it should be trivial.
AK: Another place we could simplify through a coro would be the spaghetti which is Tcllib's ftp package.
NEM 2008-09-08: I have a bare-bones coroutine ensemble at Coroutines for event-based programming. [info coroutine] (or at least the current version) does return the empty string when not in a coroutine. Putting some this stuff into tcllib would be a good idea (I'll happily volunteer to maintain it). In the short-term, I don't see that coro's could clean up tcllib event based code, as that would obviously limit the code to work only with 8.6+. Easier to structure everything in terms of callbacks and then just allow an easy way to wrap a coroutine around a call to make it look synchronous (as in the http example below).
AK: Definitely agree that this is not a short-term thing. Also agree that having this in Tcllib would be very nice.
NEM Here's another example - asynchronous HTTP requests using a synchronous interface:
proc get url {
http::geturl $url -command [info coroutine]
yield
}
proc main {} {
set t [get http://wiki.tcl.tk/4]
puts [http::data $t]
http::cleanup $t
}
coroutine m mainZB When trying to run it with just "m" - it's answering: can't read "state(body)": no such variable
NEM The coroutine is already running, you don't need to invoke it: just start the event loop:
vwait forever
MHN in c.l.t I recently posted some issues with coroutine::auto, but I feel like this code is better "maintained" here:
#!/usr/bin/env tclsh
package require Tcl 8.6
# wrapper: run this script in a coroutine and wait for that coroutine to exit
if {{} eq [info coroutine]} {
coroutine [info script] apply {script {source $script; exit}} [info script]
vwait forever
}
# make sure that the above vwait forever is the outer-most event loop: enter it now
::after idle [info coroutine]
yield
# demonstrate the order of execution: helper code
# timeline is a list of integers 1 2 3 ...
global timeline
proc reset {} {
set ::timeline {}
}
proc verify {} {
update
global timeline
foreach cur $timeline {
if {[incr i] != $cur} {
puts stderr "unexpected order of execution ($i != $cur): $timeline"
return false
}
}
return true
}
reset
trace add variable timeline write [format {apply {args {puts stderr "timeline write ([expr {[clock seconds] - %d}]s): $::timeline"}}} [clock seconds]]
###############################
puts stderr "legacy after"
reset
after 1000 {lappend timeline 3}
lappend timeline 1
after 2000 ;# synchronous after blocks asynchronous after
lappend timeline 2
verify
puts stderr "legacy vwait" ;# from man vwait
reset
after 1000 {
lappend timeline 2
vwait b ;# nested vwait blocks ...
lappend timeline 4
}
after 2000 {
lappend timeline 3
set a 10 ;# ... releasing of ...
}
after 3000 {
# release deadlock
set b 42
}
lappend timeline 1
vwait a ;# ... the outer vwait
set b 42
lappend timeline 5
verify
puts stderr "legacy update"
reset
after 200 {
lappend timeline 2
}
after 100 {
lappend timeline 1
after 0 {
lappend timeline 5
}
}
after 300 {
lappend timeline 3
}
after 400
after 0 {
lappend timeline 4
}
verify
# Using coroutine::auto I expect the following without changing any of the above code:
# * after:
# - timeline lappend changes from 3 1 2 to 2 1 3
# * vwait:
# - timeline lappend changes from 2 4 3 1 5 to 2 5 3 1 4
# - no deadlock occurs
# * update:
# - timeline lappend changes from 2 1 5 3 4 to 3 1 2 4 5 (because of after, not update)
# XXX still need to "hook" all callback code and make it a coroutine
# XXX only works with legacy update!
###############################
package require coroutine::auto
###############################
puts stderr "coroutine after"
reset
after 1000 ::coroutine::util create eval {{
lappend ::timeline 2
}}
lappend timeline 1
after 2000 ;# after 1000 comes before after 2000
lappend timeline 3
verify
puts stderr "coroutine vwait"
package require coroutine::auto
reset
after 1000 ::coroutine::util create eval {{
lappend timeline 2
vwait ::b ;# released just before verify, continued during update in verify
lappend timeline 5
}}
after 2000 ::coroutine::util create eval {{
lappend timeline 3
set ::a 10
}}
lappend timeline 1
vwait ::a ;# released after 2000
lappend timeline 4
set ::b 42
verify
puts stderr "coroutine update"
reset
after 200 {
lappend timeline 3
}
after 100 {
lappend timeline 1
after 0 {
lappend timeline 2
}
}
after 300 {
lappend timeline 4
}
after 400
after 0 {
lappend timeline 5
}
verifyMHN when running this script, we can see that wrapped update and wrapped vwait don't play nicely together. I tracked it down to the decoupling by Peter Spjuth: ::coroutine::util::update queues "after 0" to resume. On the other hand, vwait queues another "after idle" after that ...
Therefore ::coroutine::util::update does not "bring the application “up to date” by entering the event loop repeatedly until all pending events (including idle callbacks) have been processed", but seems to only process events that have been registered before update was called.