Posted to tcl by colin at Thu May 31 00:41:04 GMT 2012view raw
- # Threads - asynchronous thread
- if {[info exists argv0] && $argv0 eq [info script]} {
- lappend ::auto_path .
- }
- package require Thread
- #package require Debug
- Debug define thread
- package require OO
- oo::class create ::Thread {
- # response - process response from next call
- method response {var _id op} {
- if {[catch {
- upvar 1 $var result
- variable id
- if {$id ne $_id} {
- error "[self] response $var $_id $op - did not match $id"
- }
- # get the async response
- lassign $result($id) code e eo
- unset result($id)
- # get the associated scripts
- variable responder
- variable next
- lassign $responder([incr next]) response error
- unset responder($next)
- #Debug.thread {response $next: $var $_id $op -> code:$code e:$e eo:($eo)}
- # invoke the appropriate script to process result
- switch -- $code {
- return - 2 -
- ok - 0 {
- if {$response ne ""} {
- #Debug.thread {DO: $response $e}
- {*}$response $e
- } else {
- #Debug.thread {DO EMPTY}
- }
- }
- default {
- if {$error eq ""} {
- ::return -code $code -options $eo $e
- } else {
- {*}$error $code $e $eo
- }
- }
- }
- } e eo]} {
- puts stderr "ERR: $e $eo"
- }
- }
- # call - asynchronously send call script to thread
- # callback $response on success, $error on error
- method call {call {response {}} {error {}}} {
- variable id
- #Debug.thread {$id call$rcount ($call) response:($response) error:($error)}
- variable responder
- variable rcount
- set responder([incr rcount]) [list $response $error]
- ::thread::send -async $id [list ::_thread::call $call] [classvar_name waiter]($id)
- }
- # preserve - incr thread refcount
- method preserve {} {
- variable id
- thread::preserve $id
- }
- # release - decr thread refcount
- method release {} {
- variable id
- ::thread::release $id
- }
- destructor {
- classvar waiter
- unset waiter($id)
- my release
- }
- method waiter {} {
- #return ::WAITER
- return [classvar_name waiter]
- }
- constructor {args} {
- if {[llength $args]%2} {
- variable script [lindex $args end]
- set args [lrange $args 0 end-1]
- } else {
- variable script {}
- }
- variable prescript {
- package require Thread
- namespace eval ::_thread {
- # call - run the script, return the full result
- proc call {script} {
- list [catch {uplevel #0 $script} e eo] $e $eo
- }
- proc call {script} {
- set result [list [catch {uplevel #0 $script} e eo] $e $eo]
- return $result
- }
- }
- }
- variable postscript {
- ::thread::wait
- }
- variable {*}$args
- variable next ;# next expected response
- variable rcount ;# last sent request
- variable id [::thread::create -preserved $prescript$script$postscript]
- ::thread::configure $id -eventmark 3
- classvar waiter
- set waiter($id) {}
- trace add variable [classvar_name waiter]($id) write [list [self] response]
- }
- }
- if {[info exists argv0] && $argv0 eq [info script]} {
- #Debug on thread
- set max 10
- for {set i 0} {$i < $max} {incr i} {
- set thread($i) [Thread new {
- proc terror {args} {
- puts stderr [::thread::id]:$args
- }
- ::thread::errorproc terror
- interp bgerror "" terror
- }]
- }
- interp bgerror "" output
- proc output {args} {
- puts stderr $args
- }
- after idle {
- time {
- set i [expr {int(rand() * $max)}]
- $thread($i) call ::thread::id [list output $i:]
- after 1
- } 20
- }
- set waiter [$thread(0) waiter]
- puts stderr "WAITER: [array get $waiter]"
- while {1} {
- vwait $waiter
- puts stderr "WAITER: [array get $waiter]"
- }
- }