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

  1. proc cgets {chan args} {
  2. if {[llength $args] == 1} {
  3. upvar 1 [lindex $args 0] line
  4. } elseif {[llength $args] > 1} {
  5. return -code error "wrong \# args, should be \"[lindex [info level 0] 0] channel ?variable?\""
  6. }
  7. while {1} {
  8. set blocking [fconfigure $chan -blocking]
  9. fconfigure $chan -blocking 0
  10. set status [catch {gets $chan line} result opts]
  11. if {$status} {
  12. fconfigure $chan -blocking $blocking
  13. return -code $status -options $opts
  14. } elseif {[fblocked $chan]} {
  15. fileevent $chan readable [list [info coroutine]]
  16. yield
  17. fileevent $chan readable {}
  18. } else {
  19. fconfigure $chan -blocking $blocking
  20. if {[llength $args] == 1} {
  21. return $result
  22. } else {
  23. return $line
  24. }
  25. }
  26. }
  27. }
  28.  
  29. coroutine foo apply {{} {
  30. while {[cgets stdin line] >= 0} {
  31. puts $line
  32. }
  33. set ::finished 1
  34. }}
  35.  
  36. vwait finished