Posted to tcl by colin at Wed Nov 17 00:49:24 GMT 2010view pretty

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