Posted to tcl by patthoyts at Tue May 01 13:46:22 GMT 2007view raw

  1. # Demonstrate the use of asynchronous sockets with a thread pool
  2. # This expects to connect to an SMTP server. The task we are to
  3. # perform is to connect to the server, and then immediately issue a QUIT
  4. #
  5.  
  6. package require Thread
  7.  
  8. set program {
  9. variable uid 0
  10.  
  11. proc OnWrite {State} {
  12. upvar #0 $State state
  13. lappend state(calls) w
  14. fileevent $state(socket) writable {}
  15. }
  16.  
  17. proc OnRead {State} {
  18. upvar #0 $State state
  19. set rd r
  20. if {[eof $state(socket)]} {
  21. fileevent $state(socket) readable {}
  22. set state(wait) eof
  23. lappend state(calls) re
  24. return
  25. }
  26. if {[gets $state(socket) line] != -1} {
  27. #lappend state(input) $line
  28. append rd [string length $line]
  29. if {!$state(quit)} {
  30. set state(quit) 1
  31. puts $state(socket) "QUIT"
  32. }
  33. } else {
  34. append rd 0
  35. }
  36. lappend state(calls) $rd
  37. }
  38.  
  39. proc Test {host port} {
  40. variable uid
  41. set State [namespace current]::test[incr uid]
  42. upvar #0 $State state
  43. array set state [list tid [thread::id] quit 0 calls {}]
  44. if {[catch {set state(socket) [socket -async $host $port]} err]} {
  45. set result "ERROR: $err"
  46. } else {
  47. set state(aid) [after 5000 [list set [set State](wait) timeout]]
  48. fconfigure $state(socket) -blocking 1 -buffering line -translation crlf
  49. fileevent $state(socket) writable [list OnWrite $State]
  50. fileevent $state(socket) readable [list OnRead $State]
  51.  
  52. vwait [set State](wait)
  53. after cancel $state(aid)
  54. catch {close $state(socket)}
  55. set result [array get state]
  56. }
  57. unset $State
  58. return $result
  59. }
  60. }
  61.  
  62. proc Threaded {host port} {
  63. variable program
  64. # Create a pool of threads and initialize them with our code
  65. set poolid [tpool::create -maxworkers 20 -initcmd $program]
  66.  
  67. # Create a number of job requests and submit the jobs to the pool.
  68. # We keep an id for each job so we can track when they complete
  69. set jids {}
  70. for {set n 0} {$n < 5000} {incr n} {
  71. lappend jids [tpool::post -nowait $poolid [list Test $host $port]]
  72. }
  73.  
  74. # Wait for the jobs we submitted to complete. Collect the results
  75. # and remove completed jobs from the set of job ids so that we can
  76. # wait on the running jobs each time around the outer loop.
  77. set limit 0
  78. array set r {}
  79. while {[llength $jids] > 0 && $limit < 5000} {
  80. set done [tpool::wait $poolid $jids]
  81. foreach id $done {
  82. #puts "[format %2d $id]: [tpool::get $poolid $id]"
  83. array set a [tpool::get $poolid $id]
  84. if {![info exists r($a(tid))]} {
  85. set r($a(tid)) 1
  86. } else {
  87. incr r($a(tid))
  88. }
  89. set ndx [lsearch -exact $jids $id]
  90. if {$ndx != -1} {
  91. set jids [lreplace $jids $ndx $ndx]
  92. }
  93. }
  94. incr limit
  95. }
  96. if {$limit > 999} { puts "hit limit"}
  97.  
  98. # Clean up and report
  99. tpool::release $poolid
  100. foreach tid [array names r] {
  101. puts "$tid [format {% 3d} $r($tid)]\
  102. [string repeat . [expr {int((60/400.0) * $r($tid))}]]"
  103. }
  104. return
  105. }
  106.  
  107. if {!$tcl_interactive} {
  108. set r [catch [linsert $argv 0 Threaded] err]
  109. if {$r} {puts $::errorInfo} else {puts $err}
  110. exit
  111. }