Posted to tcl by aspect at Mon May 28 14:07:55 GMT 2018view raw
- package require Thread
- proc go {args} {coroutine go#[info cmdcount] {*}$args}
- proc yieldm {val} {yieldto string cat $val}
- proc asocket {args} {
- set t [thread::create]
- thread::send $t [list set args $args]
- thread::send $t [list set tid [thread::id]]
- thread::send $t [list set callback [info coroutine]]
- thread::send -async $t {
- set rc [catch {socket {*}$args} res opts]
- if {$rc == 0} {thread::transfer $tid $res} ;# on success, pass the chan back
- thread::send $tid [list {*}$callback $rc $res $opts] ;# send back the result, including error code
- thread::exit
- }
- lassign [yieldto string cat] rc res opts ;# wait for a result
- return -code $rc {*}$opts $res ;# return a socket or error
- }
- proc connect {args} {
- puts "connecting to $args"
- try {
- set sock [asocket {*}$args]
- puts "connected to $args: $sock"
- close $sock
- } on error {e} {
- puts "connect error $args: $e"
- }
- }
- proc main {args} {
- foreach {host port} $args {
- go connect $host $port ;# spawn a coro for each connection
- }
- }
- proc watch {ms args} {
- set threads {}
- while 1 {
- set r [{*}$args]
- if {$r ne $threads} {
- set threads $r
- puts "Threads: $threads"
- }
- after $ms [info coroutine]
- yield
- }
- }
- go watch idle thread::names
- coroutine Main main {*}$::argv
- vwait forever
- # $ tclsh sockinthread.tcl abc.net.au 80 www.tcl.tk 80 localhost 80 ghhg.deokde 123
- # Threads: tid0x7f8b1734f680
- # connecting to abc.net.au 80
- # connecting to www.tcl.tk 80
- # connecting to localhost 80
- # connecting to ghhg.deokde 123
- # connect error localhost 80: couldn't open socket: connection refused
- # Threads: tid0x7f8b029dc700 tid0x7f8b031dd700 tid0x7f8b03fff700 tid0x7f8b091fd700 tid0x7f8b1734f680
- # Threads: tid0x7f8b029dc700 tid0x7f8b03fff700 tid0x7f8b091fd700 tid0x7f8b1734f680
- # connect error ghhg.deokde 123: couldn't open socket: Name or service not known
- # Threads: tid0x7f8b03fff700 tid0x7f8b091fd700 tid0x7f8b1734f680
- # connected to www.tcl.tk 80: sock7f8afc065fb0
- # Threads: tid0x7f8b091fd700 tid0x7f8b1734f680
- # connected to abc.net.au 80: sock7f8b0405c010
- # Threads: tid0x7f8b1734f680