# copyright (C) 1997-2006 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

# $Id: threads.tcl,v 1.16 2006/01/28 19:16:59 jfontain Exp $


package present Thread 2.5
package provide threads [lindex {$Revision: 1.16 $} 1]


namespace eval threads {

    proc error {thread information} {
        variable errorScript

        if {[info exists errorScript($thread)]} {
            uplevel #0 $errorScript($thread) [list $information]                                    ;# always invoke at global level
        } else {
            puts stderr $information
            exit 1
        }
    }

    thread::errorproc ::threads::error

    proc catchError {thread script} {
        variable errorScript

        if {[string length $script] == 0} {
            catch {unset errorScript($thread)}
        } else {
            set errorScript($thread) $script
        }
    }

}


class worker {

    proc worker {this} {
        set ($this,thread) [thread::create -preserved]                     ;# so that thread can be released in a controlled fashion
        threads::catchError $($this,thread) "worker::error $this"
    }

    proc ~worker {this} {
        thread::release $($this,thread)
        threads::catchError $($this,thread) {}
    }

    proc error {this information} {
        set ($this,information) $information         ;# there was an error during the script invocation: store the error information
    }

    proc command {this args} {                                                                    ;# ignore trace callback arguments
        set result $($this,result)                                  ;# the script result if there was no error, or the error message
        set information $($this,information)        ;# empty if there was no error, else the error information including stack trace
        unset ($this,result) ($this,information)
        uplevel #0 $($this,command) [list $result] [list $information]                              ;# always invoke at global level
    }

    # public procedure: evaluate script in background (unblocks), wait till completion, can be caught as a regular procedure
    proc wait {this script} {
        if {[info exists ($this,information)]} {
            ::error {scripts queuing not implemented}
        }
        set ($this,information) {}
        thread::send -async $($this,thread) $script worker::($this,data)     ;# do not use result member as it interferes with trace
        vwait worker::($this,data)
        set result $($this,data)
        set information $($this,information)
        unset ($this,data) ($this,information)
        if {[string length $information] > 0} {                                                                ;# there was an error
            ::error $result                                                                   ;# variable contains the error message
        } else {
            return $result
        }
    }

    # public procedure:
    # let the thread invoke the script, in background with callback if command defined
    # to invoke in background while ignoring the result, use Tcl list command: evaluate $worker $script list
    proc evaluate {this script {command {}}} {
        if {[info exists ($this,information)]} {
            ::error {scripts queuing not implemented}
        }
        if {[string length $command] == 0} {                                                             ;# no background invocation
            return [thread::send $($this,thread) $script]                                                    ;# immediate invocation
        }
        set ($this,information) {}
        set ($this,command) $command
        thread::send -async $($this,thread) $script worker::($this,result)                                  ;# background invocation
        trace variable worker::($this,result) w "worker::command $this"
    }

}
