Posted to tcl by aspect at Sun Jun 26 04:35:18 GMT 2011view raw

  1. namespace eval echo {
  2. proc gets {args} {
  3. if {[info coroutine] == ""} {
  4. return [::gets {*}$args]
  5. } else {
  6. set sock [lindex $args end]
  7. after cancel [info coroutine] timeout
  8. after 2000 [info coroutine] timeout
  9. while {[set data [::gets $sock]] == ""} {
  10. if {[eof $sock]} {
  11. return {}
  12. #return -code error "EOF on $sock"
  13. }
  14. switch -exact [yield] {
  15. timeout {
  16. return -code error "timeout"
  17. }
  18. close {
  19. return -code error "forced close"
  20. }
  21. }
  22.  
  23. }
  24. return $data
  25. }
  26. }
  27.  
  28. proc echo {sock host port} {
  29. puts "echo starting"
  30. while {![eof $sock]} {
  31. puts $sock [gets $sock]
  32. puts "echoing"
  33. }
  34. }
  35. }
  36.  
  37. namespace eval clients {}
  38.  
  39. proc handle {sock host port} {
  40. puts "new connection from $host:$port"
  41. after 2000 [info coroutine] timeout
  42. yield
  43. if {[catch {echo::echo $sock $host $port} result]} {
  44. puts "Error handling $host:$port: $result"
  45. }
  46. catch {close $sock}
  47. puts "connection closed $host:$port"
  48. }
  49.  
  50. proc accept {sock host port} {
  51. coroutine clients::$host:$port handle $sock $host $port
  52. chan configure $sock -blocking 0 -buffering line
  53. chan event $sock readable clients::$host:$port
  54. }
  55.  
  56.  
  57. socket -server accept 1234
  58.  
  59. if {!$::tcl_interactive} {vwait forever}
  60.