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
}
}