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