#! /bin/env tclsh
package require {ycl shelf shelf}
namespace import [yclprefix]::shelf::shelf
package require {ycl test}
proc suite_main {} {
package require {ycl list}
namespace import [yclprefix]::list::sl
package require {ycl coro call}
namespace import [yclprefix]::coro::call::autocall
namespace import [yclprefix]::coro::call::body
namespace import [yclprefix]::coro::call::bye
namespace import [yclprefix]::coro::call::call
namespace import [yclprefix]::coro::call::callroutine
namespace import [yclprefix]::coro::call::forward
namespace import [yclprefix]::coro::call::hi
namespace import [yclprefix]::coro::call::new
namespace import [yclprefix]::coro::call::receive
namespace import [yclprefix]::coro::call::relay
namespace import [yclprefix]::coro::call::replier
namespace import [yclprefix]::coro::call::reply
namespace import [yclprefix]::coro::call::replyafter
namespace import [yclprefix]::coro::call::timeout
[yclprefix] test init
namespace import [yclprefix]::test::cleanup1
test after {} -setup {} -body {
variable res
coroutine c3 ::apply [list {} {
hi
# Never replies
} [namespace current]]
coroutine c1 ::apply [list {} {
variable res
hi
timeout 100 {the answer}
lappend res [call c3]
lappend res [namespace tail [replier]]
} [namespace current]]
coroutine c2 ::apply [list {} {
yield
call c1
} [namespace current]]
after 0 [list [namespace which c2]]
vwait [namespace current]::res
return $res
} -cleanup [cleanup1] -result [sl {
{the answer} c1
}]
test after_error {} -setup {} -body {
variable res
coroutine c3 ::apply [list {} {
hi
# Never replies
} [namespace current]]
coroutine c1 ::apply [list args {
variable res
hi
timeout 100 -code error {bleep bloop}
catch {call c3} cres copts
lappend res $cres [dict get $copts -code] [
namespace tail [replier]]
} [namespace current]]
coroutine c2 ::apply [list args {
yield
call c1
} [namespace current]]
after 0 [list [namespace which c2]]
vwait [namespace current]::res
return $res
} -cleanup [cleanup1] -result [sl {
{bleep bloop} 1 c1
}]
test autocall {} -setup {} -body {
variable res
coroutine c1\0 ::apply [list args {
hi
after 100 [list [info coroutine]]
yield
reply 5
} [namespace current]]
autocall c1
coroutine c2 ::apply [list args {
variable res
yield
lappend res [c1]
} [namespace current]]
after 0 [list [namespace which c2]]
vwait [namespace current]::res
return $res
} -cleanup [cleanup1] -result [sl {
5
}]
test autocall_resolve {
The target command is resolved relative to the namespace the source
command is created in.
} -setup {} -body {
variable res
namespace eval c1 [list coroutine coro ::apply [list args {
hi
after 100 [list [info coroutine]]
yield
reply 5
} [namespace current]]]
autocall c1 c1::coro
coroutine c2 ::apply [list args {
variable res
yield
lappend res [c1]
} [namespace current]]
after 0 [list [namespace which c2]]
vwait [namespace current]::res
return $res
} -cleanup [cleanup1] -result [sl {
5
}]
test basic {} -setup {} -body {
variable res
coroutine c1 ::apply [list args {
hi
after 100 [list [info coroutine]]
yield
set args [reply 5]
} [namespace current]]
coroutine c2 ::apply [list args {
variable res
yield
set res [call c1]
} [namespace current]]
after 0 [list [namespace which c2]]
vwait [namespace current]::res
return $res
} -cleanup [cleanup1] -result [sl {
5
}]
test break {} -setup {} -body {
variable res
coroutine c1 ::apply [list args {
hi
after 100 [list [info coroutine]]
yield
set args [reply 5]
bye
} [namespace current]]
coroutine c2 ::apply [list args {
yield
variable res
set new {}
while 1 {
lappend new [call c1]
}
lappend res $new
} [namespace current]]
after 0 [list [namespace which c2]]
vwait [namespace current]::res
lappend res [namespace which c1]
return $res
} -cleanup [cleanup1] -result [sl {
5 {}
}]
test multi {} -setup {} -body {
variable res
coroutine c1 ::apply [list args {
hi
after 100 [list [info coroutine]]
yield
reply 5
after 100 [list [info coroutine]]
yield
reply 10
reply -code break
reply 20
reply -code break
} [namespace current]]
coroutine c2 ::apply [list args {
variable res
yield
while 1 {
lappend new [call c1]
}
while 1 {
lappend new [call c1]
}
set res $new
} [namespace current]]
after 0 [list [namespace which c2]]
vwait [namespace current]::res
return $res
} -cleanup [cleanup1] -result [sl {
5 10 20
}]
test error {} -setup {} -body {
variable res
coroutine c1 ::apply [list args {
hi
after 100 [list [info coroutine]]
yield
catch {abadcommand} cres copts
reply -options $copts $cres
} [namespace current]]
coroutine c2 ::apply [list args {
variable res
yield
catch {call c1} cres opts
lappend res [dict get $opts -code] $cres
} [namespace current]]
after 0 [list [namespace which c2]]
vwait [namespace current]::res
return $res
} -cleanup [cleanup1] -result [sl {
1 {invalid command name "abadcommand"}
}]
test body {} -setup {} -body {
proc r1 arg1 [body {
hi
for {set i 3} {$i < 8} {incr i} {
reply $i
}
}]
callroutine c1 r1 something
while 1 {
lappend res [c1]
}
return $res
} -cleanup [cleanup1] -result [sl {
3 4 5 6 7
}]
test body_scripterror {} -setup {} -body {
proc r1 arg1 [body {
hi
not [a good script
}]
callroutine c1 r1 something
catch c1 cres copts
return $cres
} -cleanup [cleanup1] -result [sl {
missing close-bracket
}]
test forward {} -setup {} -body {
variable result
proc r1 {} [body {
set arg1 [hi]
for {set i 3} {$i < 8} {incr i} {
set arg1 [reply [list $i $arg1]]
}
}]
coroutine c1 r1
coroutine recipient ::apply [list destination {
set target [list ::return -level 0]
set item {}
set copts {}
while 1 {
catch {call {*}$target -options $copts $item} item copts
set target [list $destination]
}
} [namespace current]] [info coroutine]
while 1 {
lappend res [forward [namespace which recipient] [namespace which c1] [expr {[incr i] + 11}]]
}
return $res
} -cleanup [cleanup1] -result [sl {
{3 12} {4 13} {5 14} {6 15} {7 16}
}]
test new {} -setup {} -body {
variable res
new c1 ::apply [list args {
hi
after 100 [list [info coroutine]]
yield
set args [reply 5]
} [namespace current]]
coroutine c2 ::apply [list args {
variable res
yield
set res [c1]
} [namespace current]]
after 0 [list [namespace which c2]]
vwait [namespace current]::res
return $res
} -cleanup [cleanup1] -result [sl {
5
}]
cleanupTests
}