Posted to tcl by colin at Thu May 31 00:52:26 GMT 2012view pretty
# 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 count op} { if {[catch { upvar 1 $var result variable id # get the async response lassign $result($count) code e eo unset result($count) # get the associated scripts variable responder variable next lassign $responder([incr next]) response error unset responder($next) Debug.thread {response $next: $var $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 variable responder variable rcount set responder([incr rcount]) [list $response $error] Debug.thread {$id call$rcount ($call) response:($response) error:($error)} ::thread::send -async $id [list ::_thread::call $call] [namespace current]::waiter($rcount) } # preserve - incr thread refcount method preserve {} { variable id thread::preserve $id } # release - decr thread refcount method release {} { variable id ::thread::release $id } destructor { my release } 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 trace add variable [namespace current]::waiter 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 } while {1} { vwait forever } }