Posted to tcl by aspect at Mon May 28 14:07:55 GMT 2018view raw

  1. package require Thread
  2.  
  3. proc go {args} {coroutine go#[info cmdcount] {*}$args}
  4. proc yieldm {val} {yieldto string cat $val}
  5.  
  6. proc asocket {args} {
  7. set t [thread::create]
  8.  
  9. thread::send $t [list set args $args]
  10. thread::send $t [list set tid [thread::id]]
  11. thread::send $t [list set callback [info coroutine]]
  12.  
  13. thread::send -async $t {
  14. set rc [catch {socket {*}$args} res opts]
  15. if {$rc == 0} {thread::transfer $tid $res} ;# on success, pass the chan back
  16. thread::send $tid [list {*}$callback $rc $res $opts] ;# send back the result, including error code
  17. thread::exit
  18. }
  19.  
  20. lassign [yieldto string cat] rc res opts ;# wait for a result
  21. return -code $rc {*}$opts $res ;# return a socket or error
  22. }
  23.  
  24. proc connect {args} {
  25. puts "connecting to $args"
  26. try {
  27. set sock [asocket {*}$args]
  28. puts "connected to $args: $sock"
  29. close $sock
  30. } on error {e} {
  31. puts "connect error $args: $e"
  32. }
  33. }
  34.  
  35. proc main {args} {
  36. foreach {host port} $args {
  37. go connect $host $port ;# spawn a coro for each connection
  38. }
  39. }
  40.  
  41. proc watch {ms args} {
  42. set threads {}
  43. while 1 {
  44. set r [{*}$args]
  45. if {$r ne $threads} {
  46. set threads $r
  47. puts "Threads: $threads"
  48. }
  49. after $ms [info coroutine]
  50. yield
  51. }
  52. }
  53.  
  54. go watch idle thread::names
  55. coroutine Main main {*}$::argv
  56. vwait forever
  57.  
  58. # $ tclsh sockinthread.tcl abc.net.au 80 www.tcl.tk 80 localhost 80 ghhg.deokde 123
  59. # Threads: tid0x7f8b1734f680
  60. # connecting to abc.net.au 80
  61. # connecting to www.tcl.tk 80
  62. # connecting to localhost 80
  63. # connecting to ghhg.deokde 123
  64. # connect error localhost 80: couldn't open socket: connection refused
  65. # Threads: tid0x7f8b029dc700 tid0x7f8b031dd700 tid0x7f8b03fff700 tid0x7f8b091fd700 tid0x7f8b1734f680
  66. # Threads: tid0x7f8b029dc700 tid0x7f8b03fff700 tid0x7f8b091fd700 tid0x7f8b1734f680
  67. # connect error ghhg.deokde 123: couldn't open socket: Name or service not known
  68. # Threads: tid0x7f8b03fff700 tid0x7f8b091fd700 tid0x7f8b1734f680
  69. # connected to www.tcl.tk 80: sock7f8afc065fb0
  70. # Threads: tid0x7f8b091fd700 tid0x7f8b1734f680
  71. # connected to abc.net.au 80: sock7f8b0405c010
  72. # Threads: tid0x7f8b1734f680
  73.