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