Posted to tcl by colin at Thu May 31 00:41:04 GMT 2012view raw

  1. # Threads - asynchronous thread
  2. if {[info exists argv0] && $argv0 eq [info script]} {
  3. lappend ::auto_path .
  4. }
  5. package require Thread
  6. #package require Debug
  7. Debug define thread
  8. package require OO
  9.  
  10. oo::class create ::Thread {
  11. # response - process response from next call
  12. method response {var _id op} {
  13. if {[catch {
  14. upvar 1 $var result
  15. variable id
  16. if {$id ne $_id} {
  17. error "[self] response $var $_id $op - did not match $id"
  18. }
  19.  
  20. # get the async response
  21. lassign $result($id) code e eo
  22. unset result($id)
  23.  
  24. # get the associated scripts
  25. variable responder
  26. variable next
  27. lassign $responder([incr next]) response error
  28. unset responder($next)
  29.  
  30. #Debug.thread {response $next: $var $_id $op -> code:$code e:$e eo:($eo)}
  31.  
  32. # invoke the appropriate script to process result
  33. switch -- $code {
  34. return - 2 -
  35. ok - 0 {
  36. if {$response ne ""} {
  37. #Debug.thread {DO: $response $e}
  38. {*}$response $e
  39. } else {
  40. #Debug.thread {DO EMPTY}
  41. }
  42. }
  43. default {
  44. if {$error eq ""} {
  45. ::return -code $code -options $eo $e
  46. } else {
  47. {*}$error $code $e $eo
  48. }
  49. }
  50. }
  51. } e eo]} {
  52. puts stderr "ERR: $e $eo"
  53. }
  54. }
  55.  
  56. # call - asynchronously send call script to thread
  57. # callback $response on success, $error on error
  58. method call {call {response {}} {error {}}} {
  59. variable id
  60. #Debug.thread {$id call$rcount ($call) response:($response) error:($error)}
  61.  
  62. variable responder
  63. variable rcount
  64. set responder([incr rcount]) [list $response $error]
  65.  
  66. ::thread::send -async $id [list ::_thread::call $call] [classvar_name waiter]($id)
  67. }
  68.  
  69. # preserve - incr thread refcount
  70. method preserve {} {
  71. variable id
  72. thread::preserve $id
  73. }
  74.  
  75. # release - decr thread refcount
  76. method release {} {
  77. variable id
  78. ::thread::release $id
  79. }
  80.  
  81. destructor {
  82. classvar waiter
  83. unset waiter($id)
  84.  
  85. my release
  86. }
  87.  
  88. method waiter {} {
  89. #return ::WAITER
  90. return [classvar_name waiter]
  91. }
  92.  
  93. constructor {args} {
  94. if {[llength $args]%2} {
  95. variable script [lindex $args end]
  96. set args [lrange $args 0 end-1]
  97. } else {
  98. variable script {}
  99. }
  100.  
  101. variable prescript {
  102. package require Thread
  103. namespace eval ::_thread {
  104. # call - run the script, return the full result
  105. proc call {script} {
  106. list [catch {uplevel #0 $script} e eo] $e $eo
  107. }
  108. proc call {script} {
  109. set result [list [catch {uplevel #0 $script} e eo] $e $eo]
  110. return $result
  111. }
  112. }
  113. }
  114.  
  115. variable postscript {
  116. ::thread::wait
  117. }
  118.  
  119. variable {*}$args
  120. variable next ;# next expected response
  121. variable rcount ;# last sent request
  122.  
  123. variable id [::thread::create -preserved $prescript$script$postscript]
  124. ::thread::configure $id -eventmark 3
  125. classvar waiter
  126. set waiter($id) {}
  127. trace add variable [classvar_name waiter]($id) write [list [self] response]
  128. }
  129. }
  130.  
  131. if {[info exists argv0] && $argv0 eq [info script]} {
  132. #Debug on thread
  133. set max 10
  134. for {set i 0} {$i < $max} {incr i} {
  135. set thread($i) [Thread new {
  136. proc terror {args} {
  137. puts stderr [::thread::id]:$args
  138. }
  139. ::thread::errorproc terror
  140. interp bgerror "" terror
  141. }]
  142. }
  143. interp bgerror "" output
  144.  
  145. proc output {args} {
  146. puts stderr $args
  147. }
  148.  
  149. after idle {
  150. time {
  151. set i [expr {int(rand() * $max)}]
  152. $thread($i) call ::thread::id [list output $i:]
  153. after 1
  154. } 20
  155. }
  156.  
  157. set waiter [$thread(0) waiter]
  158. puts stderr "WAITER: [array get $waiter]"
  159. while {1} {
  160. vwait $waiter
  161. puts stderr "WAITER: [array get $waiter]"
  162. }
  163. }