Posted to tcl by colin at Wed Nov 17 00:49:24 GMT 2010view raw
- namespace eval tcl::unsupported namespace export yieldm
- namespace import tcl::unsupported::yieldm
- proc reader {} {
- while {1} {
- ::yieldm
- }
- }
- oo::class create ::Lamb {
- # reader - main coroutine supervising connection
- method reader {} {
- while {1} {
- ::yieldm
- }
- }
- constructor {args} {
- variable ns [info object namespace [self]]
- variable coro ${ns}::coro
- ::coroutine $coro [self] reader ;# will crash
- #::coroutine $coro ::reader ;# will not crash
- }
- }
- proc every {interval script} {
- global everyIds
- if {$interval eq "cancel"} {
- after cancel $everyIds($script)
- return
- }
- set everyIds($script) [after $interval [info level 0]]
- set rc [catch {uplevel #0 $script} result]
- if {$rc == [catch break]} {
- after cancel $everyIds($script)
- set rc 0
- } elseif {$rc == [catch continue]} {
- # Ignore - just consume the return code
- set rc 0
- }
- # TODO: Need better handling of errorInfo etc...
- return -code $rc $result
- }
- every 100 {
- set obj [Lamb new]
- puts stderr "New Lamb: $obj"
- }
- every 1000 {
- foreach o [info class instances ::Lamb] {
- catch {$o destroy}
- }
- }
- every 2000 {
- foreach o [info class instances ::Lamb] {
- if {[catch {info object namespace $o} ns]} {
- error "$o is undead"
- } else {
- if {![namespace exists $ns]} {
- puts stderr "$o namespace nonexistent"
- }
- if {![llength [info commands $o]]} {
- puts stderr "$o no command"
- }
- }
- }
- }
- set forever 0
- ::vwait forever