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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
#***
# [manpage_begin threads tclircc 0.0.1]
# [titledesc {Component threads.tcl}]
# [description]
namespace eval threads {
variable threads [list main [thread::id]]
variable log [logger::init tclircc::threads]
variable t_ns_script {
namespace eval ::t {
variable ns
variable self
proc update {} {
variable ns
thread::send -head [set ns(main)] threads::update
}
proc ns {name} {
variable ns
set ns($name)
}
proc debug {} {
variable log
parray t::ns
}
proc util_regsub_prep {data} {
set first -1
while {[set first [string first \\ $data $first+1]] != -1} {
if {[string index $data $first+1] ni {0 1 2 3 4 5 6 7 8 9}} {
continue
}
set data [string replace $data $first $first \\\\]
incr first
}
set first -1
while {[set first [string first & $data $first+1]] != -1} {
set data [string replace $data $first $first {\&}]
incr first
}
return $data
}
proc util_pctsub {script} {
set new_script {}
set idx 0
while {[set subst_start [string first "%" $script $idx]] != -1} {
append new_script [string range $script $idx $subst_start-1]
if {[string index $script $subst_start+1] == "%"} {
append new_script %
set idx [expr {$subst_start + 2}]
continue
}
regexp -start [expr {$subst_start + 1}] -indices {[^A-Za-z0-9_:]} $script match
if {[llength $match]} {
lassign $match subst_end
set subst_end $subst_end-1
} else {
set subst_end [string length $script]
}
upvar [string range $script $subst_start+1 $subst_end] subst_data
append new_script $subst_data
set idx [expr $subst_end + 1]
}
append new_script [string range $script $idx end]
return $new_script
}
proc exec {name script {followup {}}} {
variable ns
variable self
set script [uplevel [list ::t::util_pctsub $script]]
set followup [uplevel [list ::t::util_pctsub $followup]]
if [string length $followup] {
set realscript {
set result [eval %script]
set script [concat [list set result $result] ";" %followup]
thread::send -async [t::ns %self] $script
}
regsub %self $realscript [util_regsub_prep [list $self]] realscript
regsub %followup $realscript [util_regsub_prep [list $followup]] realscript
regsub %script $realscript [util_regsub_prep [list $script]] realscript
set script $realscript
}
thread::send -async [set ns($name)] $script
}
}
}
eval $t_ns_script
set ::t::self "main"
proc manage {tid name} {
variable threads
variable log
variable t_ns_script
dict set threads $name $tid
${log}::debug "managing thread $tid as \"$name\""
thread::send -head $tid [concat $t_ns_script ";" [list set ::t::self $name]]
::threads::update
}
proc unmanage {name} {
variable threads
variable log
dict unset threads $name
${log}::debug "unmanaging thread $tid (\"$name\")"
::threads::update
}
proc update {} {
variable threads
dict for {name tid} $threads {
if ![thread::exists $tid] {dict unset $threads $name}
}
dict for {name tid} $threads {
set payload {array unset t::ns; }
dict for {n t} $threads {
append payload {set t::ns(} $n {) } $t {; }
}
append payload {
if {"on_threads_update" in [info procs on_threads_update]} \
on_threads_update
}
thread::send -head $tid $payload
}
::update
}
}
#***
# [manpage_end]