Posted to tcl by kbk at Wed Jun 10 22:20:02 GMT 2009view pretty

proc cgets {chan args} {
    if {[llength $args] == 1} {
	upvar 1 [lindex $args 0] line
    } elseif {[llength $args] > 1} {
	return -code error "wrong \# args, should be \"[lindex [info level 0] 0] channel ?variable?\""
    }
    while {1} {
	set blocking [fconfigure $chan -blocking]
	fconfigure $chan -blocking 0
	set status [catch {gets $chan line} result opts]
	if {$status} {
	    fconfigure $chan -blocking $blocking
	    return -code $status -options $opts
	} elseif {[fblocked $chan]} {
	    fileevent $chan readable [list [info coroutine]]
	    yield
	    fileevent $chan readable {}
	} else {
	    fconfigure $chan -blocking $blocking
	    if {[llength $args] == 1} {
		return $result
	    } else {
		return $line
	    }
	}
    }
}

coroutine foo apply {{} {
    while {[cgets stdin line] >= 0} {
	puts $line
    }
    set ::finished 1
}}

vwait finished