Posted to tcl by aspect at Sun Jun 26 08:33:05 GMT 2011view raw

  1. proc nbsock {args} {
  2. set args [lassign $args chan cmd]
  3. puts "nbsock $chan $cmd $args"
  4. switch -exact $cmd {
  5. initialize {
  6. return {initialize finalize read write watch}
  7. }
  8. read {
  9. lassign $args id count
  10. while {[set data [chan read $chan $count]] == ""} {
  11. if {[eof $channel]} {
  12. #return {}
  13. return -code error "EOF on $sock"
  14. }
  15. }
  16. yield
  17. }
  18. write {
  19. lassign $args id data
  20. chan puts -nonewline $chan $data
  21. string length $data
  22. }
  23. finalize {
  24. close $chan
  25. }
  26. default {
  27. error "Unsupported subcommand: $cmd"
  28. }
  29. }
  30. }
  31.  
  32. proc echo {sock host port} {
  33. while {![chan eof $sock]} {
  34. puts "chan configure: [chan configure $sock]"
  35. chan puts $sock [chan gets $sock]
  36. }
  37. }
  38.  
  39. namespace eval clients {}
  40.  
  41. proc handle {sock host port} {
  42. puts "Connect: $host:$port"
  43. set sock [chan create [list read write] [list nbsock $sock]]
  44. yield
  45. if {[catch {echo $sock $host $port} result]} {
  46. puts "Error: $host:$port: $result"
  47. }
  48. puts "Closing: $host:$port"
  49. if {[catch {close $sock} res]} {
  50. puts "Error closing $host:$port: $res"
  51. }
  52. }
  53.  
  54. proc accept {sock host port} {
  55. coroutine clients::$host:$port handle $sock $host $port
  56. chan configure $sock -blocking 0 -buffering line
  57. chan event $sock readable clients::$host:$port
  58. }
  59.  
  60.  
  61. socket -server accept 1234
  62.  
  63. if {!$::tcl_interactive} {vwait forever}
  64.  
  65. proc accept {sock host port} {
  66. coroutine clients::$host:$port handle $sock $host $port
  67. chan configure $sock -blocking 0 -buffering line
  68. chan event $sock readable clients::$host:$port
  69. }
  70.  
  71.  
  72. socket -server accept 1234
  73.  
  74. if {!$::tcl_interactive} {vwait forever}
  75.