-
Notifications
You must be signed in to change notification settings - Fork 7
/
Copy pathevent.tcl
106 lines (75 loc) · 3.03 KB
/
event.tcl
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
package provide de1_event 1.0
package require lambda
package require de1_logging 1.0
#
# Generic event subscription and callbacks to listeners
#
# See specific subsystems for concrete implementations
#
# Default execution of a callback is to schedule "after idle"
# -noidle as the first parameter will schedule "after 0"
# -sync will execute immediately, prior to continuing to other callbacks or operations
#
namespace eval ::event::listener {
proc _init_callback_list {callback_list_name} {
# Callback_name should be fully qualified to target namespace
if { [namespace qualifiers $callback_list_name] == "" } {
msg -ERROR "Unqualfied name '$callback_list_name' passed to create callback lists"
set callback_list_name ::event::listener::${callback_list_name}
msg -WARNING "Using ${callback_list_name} from caller in [uplevel 1 {namespace current}]"
}
if { ! [info exists $callback_list_name] } {
array set $callback_list_name [list idle [list] noidle [list] sync [list]]
} else {
msg -WARNING "Callback list ${callback_list_name} already exists. Not initializing."
}
}
proc _generic_add {callback_list_name args} {
# args can contain zero or more of -idle, -noidle, -sync
# and exactly one "executable" (typically a bare proc or a list)
# If more than one "timing" option is present, the last will be used
# callback_list_name should be fully qualified (see _init_callback_list)
# As failure to register may result in not stopping the flow of hot water,
# throw and let caller manage if needed
if { ! [info exists $callback_list_name] } {
set errmsg "No such callback list '${callback_list_name}'. Callback NOT added."
msg -ERROR $errmsg
throw [list ::event::listener NOSUCHLIST $callback_list_name] $errmsg
}
set flag idle
set remainder [lmap elem $args \
{ expr { $elem ni [list -idle -noidle -sync] \
? $elem \
: [set flag [string range $elem 1 end]; continue]}}]
if { [llength $remainder] != 1 } {
set errmsg "Unable to register callback to ${callback_list_name} with args: '${args}'"
msg -ERROR $errmsg
throw [list ::event::listener BADARGS ${args}] $errmsg
} else {
lappend ${callback_list_name}($flag) [lindex $remainder 0]
}
}
}
namespace eval ::event::apply {
proc _generic {callback_list_name args} {
# callback_list_name should be fully qualified (see _init_callback_list)
if { ! [info exists $callback_list_name] } {
msg -ERROR "No such callback list '${callback_list_name}'. Callbacks NOT executed."
return
}
foreach cb [lindex [array get $callback_list_name sync] 1] {
# Trap errors on synchronous execution to be able to continue
try {
eval [list {*}$cb {*}$args]
} on error {result opts_dict} {
msg -ERROR "Callback from ${callback_list_name} failed for sync: {*}$cb {*}$args"
}
}
foreach cb [lindex [array get $callback_list_name noidle] 1] {
after 0 [list {*}$cb {*}$args]
}
foreach cb [lindex [array get $callback_list_name idle] 1] {
after idle [list after 0 [list {*}$cb {*}$args]]
}
}
}