# 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 forever

 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
 }

proc get url {
    http::geturl $url -command [info coroutine]
    yield
}
proc main {} {
    set t [get https://wiki.tcl-lang.org/4]
    puts [http::data $t]
    http::cleanup $t
}
coroutine m main

#!/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]} {
   # make sure that vwait forever is the outer-most event loop: enter it immediately
   after 0 [list coroutine [info script] apply {script {source $script; exit}} [info script]]
   vwait forever
}

# 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
}
verify

 ##########################################################################
 # co_expect spawn_id ?regex regex regex ...?
 # - set up coroutine-enabled Expect processing for the specified spawn_id.
 # The other arguments are regex patterns to be looked for on the spawn_id.
 # This call does not block, the calling coroutine should yield to wait for
 # input.  When matching input arrives, the yield will return the index of
 # the matched pattern, i.e. 0 for the first pattern, 1 for second, etc.
 
 proc co_expect {sid args} {
 
     set expect_args [list -i $sid]
     set pos -1
     foreach pattern $args {
         lappend expect_args -re $pattern [list [info coroutine] [incr pos]]
     }
 
     after idle expect_background $expect_args
 }
 

    exp_send "ls -1 --color=never $::filepat\n"

    set files {}

    co_expect $spawn_id op1> {\n([^\r]+)\r}
    while {[yield]} {
        set file $::expect_out(1,string)
        lappend files $file
    }

    foreach file $files {
        exp_send "gzgrep -i -n '$::target' $file | cut -c-1000\n"

        co_expect $spawn_id op1> {\n(\d+):([^\r]+)\r}
        while {[yield]} {
            set line $::expect_out(1,string)
            set text $::expect_out(2,string)
            add_match $machine $file $line $text
        }
    }

package require Expect

# Remove and return first element from the named list
proc lshift name {
    upvar $name list
    set list [lassign $list first]
    return $first
}

# Transform a list of possibly-quoted elements by removing newlines
# between elements but not within elements
proc flatter input {
    foreach line [split $input \n] {
        append lines $line
        if {[info complete $lines]} {
            append lines " "
        } else {
            append lines "\n"
        }
    }
    return $lines
}

# Coroutine-enabled version of the expect command,
# allows other coroutines to execute while waiting for input
proc co_expect args {

    # For the all-braced form of the command,
    # get the usual substitutions done in the caller's scope
    if {[llength $args] == 1} {
        set args [uplevel 1 list [flatter [lindex $args 0]]]
    }
    set resume [info coroutine]
    set timeout $::timeout
    set timeout_action {}
    upvar spawn_id spawn_id
    set expect_args {}
    set cleanup_args {}

    # Mangle the arguments into something we can pass to expect_background.
    # Note that expect_background doesn't support timeouts, so we have to
    # handle those separately.
    # Most options can just be passed through, but actions need to be wrapped
    # in a callback to this coroutine.
    while {[llength $args]} {
        set arg [lshift args]
        switch -glob -- $arg {
            -timeout {set timeout [lshift args]}
            timeout {set timeout_action [lshift args]}
            default {set timeout_action [lshift args]
                     lappend expect_args eof [list $resume $timeout_action]}
            -i {set sid [lshift args]
                    lappend expect_args -i $sid
                    lappend cleanup_args -i $sid}
            -* {lappend expect_args $arg}
            * {lappend expect_args $arg [list $resume [lshift args]]}
        }
    }

    # Link expect_out in the caller's scope to the global one
    uplevel {unset -nocomplain expect_out; global expect_out}
    
    # Setting our expectations
    expect_background {*}$expect_args

    while 1 {
        # Set up timeout processing
        if {$timeout > 0} {
            set ms [expr {$timeout * 1000}]
            set timeout_id [after $ms [list $resume $timeout_action]]
        }
        # Wait for input, when it arrives we will be passed back
        # the action to perform in the caller's scope
        set action [yield]
        if {$timeout > 0} {after cancel $timeout_id}
        set rc [catch {uplevel $action} result]

        # If exp_continue was called, loop back to wait for more input.
        # Note that we do not support the -continue_timer flag
        if {$rc == -101} continue

        # Otherwise cancel background processing for the same spawn ids
        catch [list expect_background {*}$cleanup_args]
        # and return the result from the action we ran
        return -code $rc $result
    }
}

#######################################################################
# Define a simple demo which starts a shell, feeds it a few commands,
# and processes their output.
# Then we start 3 parallel instances of this with different starting delays.
# In a serious application we would probably be spawning remote shells
# to multiple systems.

proc demo delay {
    set name [info coroutine]
    puts "$name STARTED, will delay $delay seconds"
    spawn bash
    co_expect -ex $

    exp_send "echo $name;sleep $delay;date\r"
    co_expect -re {[^\n]*202.} {puts "$name GOT '$expect_out(0,string)'"} \
                timeout {puts "$name TIMED OUT"}

    co_expect -ex $
    exp_send "ls -lart /\r"
    co_expect {
            -re {(\S+) -> (\S+)} {
            puts "$name SYMLINK $expect_out(1,string) HAS TARGET $expect_out(2,string)"
            exp_continue}
        default {puts "$name CROAK"}
        -ex $
    }
    puts "$name DONE"
}

log_user 0
coroutine tom demo 4
coroutine dick demo 8
coroutine harry demo 12

# something else to run in parallel
proc pinger {} {puts PING; after 3000 pinger}

pinger

vwait godot