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
|
# $Id: hooks.tcl,v 1.7 2004/09/17 20:30:19 aleksey Exp $
namespace eval hook {
}
proc hook::add {hook func {seq 50}} {
variable $hook
lappend $hook [list $func $seq]
set $hook [lsort -integer -index 1 [lsort -unique [set $hook]]]
}
proc hook::set_flag {hook flag} {
variable F
set idx [lsearch -exact $F(flags,$hook) $flag]
set F(flags,$hook) [lreplace $F(flags,$hook) $idx $idx]
}
proc hook::unset_flag {hook flag} {
variable F
if {![lcontain $F(flags,$hook) $flag]} {
lappend F(flags,$hook) $flag
}
}
proc hook::is_flag {hook flag} {
variable F
return [expr ![lcontain $F(flags,$hook) $flag]]
}
proc hook::run {hook args} {
variable F
variable $hook
if {![info exists $hook]} {
return
}
set F(flags,$hook) {}
foreach func [set $hook] {
set func [lindex $func 0]
set code [catch { eval $func $args } state]
debugmsg hook "$hook: [lindex $func 0] -> $state (code $code)"
if {$code && ![winfo exists .hook_err]} {
MessageDlg .hook_err -aspect 50000 -icon error \
-message "Hook $hook failed: $code\n$::errorInfo" \
-type user -buttons ok -default 0 -cancel 0
}
if {(!$code) && ([cequal $state stop])} {
break
}
}
}
proc hook::foldl {hook acc0 args} {
variable F
variable $hook
if {![info exists $hook]} {
return $acc0
}
set F(flags,$hook) {}
set acc $acc0
foreach func [set $hook] {
set func [lindex $func 0]
set code [catch { eval $func [list $acc] $args } state]
debugmsg hook "$hook: [lindex $func 0] -> $state (code $code)"
if {$code} {
if {![winfo exists .hook_err]} {
MessageDlg .hook_err -aspect 50000 -icon error \
-message "Hook $hook failed: $code\n$::errorInfo" \
-type user -buttons ok -default 0 -cancel 0
}
} else {
set acc $state
}
}
return $acc
}
|
