Posted to tcl by patthoyts at Tue May 01 13:46:22 GMT 2007view raw
- # Demonstrate the use of asynchronous sockets with a thread pool
- # This expects to connect to an SMTP server. The task we are to
- # perform is to connect to the server, and then immediately issue a QUIT
- #
- package require Thread
- set program {
- variable uid 0
- proc OnWrite {State} {
- upvar #0 $State state
- lappend state(calls) w
- fileevent $state(socket) writable {}
- }
- proc OnRead {State} {
- upvar #0 $State state
- set rd r
- if {[eof $state(socket)]} {
- fileevent $state(socket) readable {}
- set state(wait) eof
- lappend state(calls) re
- return
- }
- if {[gets $state(socket) line] != -1} {
- #lappend state(input) $line
- append rd [string length $line]
- if {!$state(quit)} {
- set state(quit) 1
- puts $state(socket) "QUIT"
- }
- } else {
- append rd 0
- }
- lappend state(calls) $rd
- }
- proc Test {host port} {
- variable uid
- set State [namespace current]::test[incr uid]
- upvar #0 $State state
- array set state [list tid [thread::id] quit 0 calls {}]
- if {[catch {set state(socket) [socket -async $host $port]} err]} {
- set result "ERROR: $err"
- } else {
- set state(aid) [after 5000 [list set [set State](wait) timeout]]
- fconfigure $state(socket) -blocking 1 -buffering line -translation crlf
- fileevent $state(socket) writable [list OnWrite $State]
- fileevent $state(socket) readable [list OnRead $State]
- vwait [set State](wait)
- after cancel $state(aid)
- catch {close $state(socket)}
- set result [array get state]
- }
- unset $State
- return $result
- }
- }
- proc Threaded {host port} {
- variable program
- # Create a pool of threads and initialize them with our code
- set poolid [tpool::create -maxworkers 20 -initcmd $program]
- # Create a number of job requests and submit the jobs to the pool.
- # We keep an id for each job so we can track when they complete
- set jids {}
- for {set n 0} {$n < 5000} {incr n} {
- lappend jids [tpool::post -nowait $poolid [list Test $host $port]]
- }
- # Wait for the jobs we submitted to complete. Collect the results
- # and remove completed jobs from the set of job ids so that we can
- # wait on the running jobs each time around the outer loop.
- set limit 0
- array set r {}
- while {[llength $jids] > 0 && $limit < 5000} {
- set done [tpool::wait $poolid $jids]
- foreach id $done {
- #puts "[format %2d $id]: [tpool::get $poolid $id]"
- array set a [tpool::get $poolid $id]
- if {![info exists r($a(tid))]} {
- set r($a(tid)) 1
- } else {
- incr r($a(tid))
- }
- set ndx [lsearch -exact $jids $id]
- if {$ndx != -1} {
- set jids [lreplace $jids $ndx $ndx]
- }
- }
- incr limit
- }
- if {$limit > 999} { puts "hit limit"}
- # Clean up and report
- tpool::release $poolid
- foreach tid [array names r] {
- puts "$tid [format {% 3d} $r($tid)]\
- [string repeat . [expr {int((60/400.0) * $r($tid))}]]"
- }
- return
- }
- if {!$tcl_interactive} {
- set r [catch [linsert $argv 0 Threaded] err]
- if {$r} {puts $::errorInfo} else {puts $err}
- exit
- }