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
|
# 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: datatrace.tcl,v 1.10 2005/01/02 00:45:07 jfontain Exp $
class dataTrace { ;# work around the strict last come first served nature of the Tcl trace command
proc dataTrace {this} {error {dataTrace objects disallowed}}
proc register {object array script {last 0}} { ;# object is a viewer or a dataTable
variable objects
variable command
variable count
if {[info exists objects($array)]} {
catch {ldelete objects($array) $object} ;# do not appear more than once
if {$last} { ;# command is to be invoked last when data update occurs
lappend objects($array) $object
} else { ;# behave like the Tcl trace command
set objects($array) [linsert $objects($array) 0 $object]
}
} else {
trace variable ${array}(updates) w "dataTrace::updated $array"
set objects($array) $object
}
if {[catch {incr count($object,$array)}]} {
set command($object,$array) $script
set count($object,$array) 1
}
}
proc unregister {object {array {}}} {
variable objects
variable command
variable count
if {[string length $array] == 0} { ;# remove all traces for the object
foreach array [array names objects] {
if {[info exists count($object,$array)]} { ;# array is monitored by this object
set count($object,$array) 0 ;# force unregistering
unregister $object $array
}
}
return
}
if {[incr count($object,$array) -1] <= 0} {
ldelete objects($array) $object
unset command($object,$array)
unset count($object,$array)
}
if {[llength $objects($array)] == 0} {
trace vdelete ${array}(updates) w "dataTrace::updated $array" ;# trace is no longer needed
unset objects($array)
}
}
proc updated {array args} { ;# a module data array was just updated, ignore trace arguments
variable objects
variable command
foreach object $objects($array) { ;# update related objects
uplevel #0 $command($object,$array)
}
}
}
|
