1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
# copyright (C) 1997-2005 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.15 2005/01/02 00:45:07 jfontain Exp $
package present Thread 2.5
package provide threads [lindex {$Revision: 1.15 $} 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"
}
}
|
