Posted to tcl by aspect at Sun Jun 26 08:25:19 GMT 2011view raw

  1. package require Tcl 8.6
  2.  
  3. proc nbsock {args} {
  4. set args [lassign $args chan cmd]
  5. puts "nbsock $chan $cmd $args"
  6. switch -exact $cmd {
  7. initialize {
  8. return {initialize finalize read write watch}
  9. }
  10. read {
  11. lassign $args id count
  12. chan read $chan $count
  13. }
  14. write {
  15. lassign $args id data
  16. chan puts -nonewline $chan $data
  17. string length $data
  18. }
  19. finalize {
  20. close $chan
  21. }
  22. default {
  23. error "Unsupported subcommand: $cmd"
  24. }
  25. }
  26. }
  27.  
  28. proc echo {sock host port} {
  29. while {![chan eof $sock]} {
  30. chan puts $sock [chan gets $sock]
  31. }
  32. }
  33.  
  34. namespace eval clients {}
  35.  
  36. proc handle {sock host port} {
  37. puts "Connect: $host:$port"
  38. set sock [chan create [list read write] [list nbsock $sock]]
  39. yield
  40. if {[catch {echo $sock $host $port} result]} {
  41. puts "Error: $host:$port: $result"
  42. }
  43. puts "Closing: $host:$port"
  44. if {[catch {close $sock} res]} {
  45. puts "Error closing $host:$port: $res"
  46. }
  47. }
  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.