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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
# (c)Jean-Luc Fontaine
proc lifo__lifo {id {size 2147483647}} {
global lifo
set lifo($id,maximumSize) $size
lifo__empty $id
}
proc lifo__push {id data} {
global lifo
lifo__tidyUp $id
if {$lifo($id,size)>=$lifo($id,maximumSize)} {
unset lifo($id,data,$lifo($id,first))
incr lifo($id,first)
incr lifo($id,size) -1
}
set lifo($id,data,[incr lifo($id,last)]) $data
incr lifo($id,size)
}
proc lifo__pop {id} {
global lifo
lifo__tidyUp $id
if {$lifo($id,last)<$lifo($id,first)} {
error "lifo($id) pop error, empty"
}
# delay unsetting popped data to improve performance by avoiding a data copy
set lifo($id,unset) $lifo($id,last)
incr lifo($id,last) -1
incr lifo($id,size) -1
return $lifo($id,data,$lifo($id,unset))
}
proc lifo__tidyUp {id} {
global lifo
if {[info exists lifo($id,unset)]} {
unset lifo($id,data,$lifo($id,unset))
unset lifo($id,unset)
}
}
proc lifo__empty {id} {
global lifo
lifo__tidyUp $id
foreach name [array names lifo $id,data,*] {
unset lifo($name)
}
set lifo($id,size) 0
set lifo($id,first) 0
set lifo($id,last) -1
}
proc new {className args} {
# calls the constructor for the class with optional arguments
# and returns a unique object identifier independent of the class name
global classNewId _db
# use local variable for id for new can be called recursively
set id [incr classNewId]
if {[llength [info procs ${className}__$className]]>0} {
bug trying to escape undo... ($_db(undo,disable))
if $_db(undo,disable) {return $id}
# avoid catch to track errors
eval ${className}__$className $id $args
}
return $id
}
proc delete {className id} {
# calls the destructor for the class and delete all the object data members
if {[llength [info procs ${className}__~$className]]>0} {
# avoid catch to track errors
${className}__~$className $id
}
global $className
# and delete all this object array members if any (assume that they were stored as $className($id,memberName))
foreach name [array names $className "$id,*"] {
unset ${className}($name)
}
}
proc textUndoer__textUndoer {id widget {depth 2147483647}} {
global textUndoer
if {[string compare [winfo class $widget] Text]!=0} {
error "textUndoer error: widget $widget is not a text widget"
}
set textUndoer($id,widget) $widget
set textUndoer($id,originalBindingTags) [bindtags $widget]
bindtags $widget [concat $textUndoer($id,originalBindingTags) UndoBindings($id)]
bind UndoBindings($id) <Control-u> "textUndoer__undo $id"
# self destruct automatically when text widget is gone
bind UndoBindings($id) <Destroy> "delete textUndoer $id"
# rename widget command
rename $widget [set textUndoer($id,originalCommand) textUndoer__original$widget]
# and intercept modifying instructions before calling original command
proc $widget {args} "
textUndoer__checkpoint $id \$args ;
eval $textUndoer($id,originalCommand) \$args;
"
set textUndoer($id,commandStack) [new lifo $depth]
set textUndoer($id,cursorStack) [new lifo $depth]
}
proc textUndoer__~textUndoer {id} {
global textUndoer
bindtags $textUndoer($id,widget) $textUndoer($id,originalBindingTags)
rename $textUndoer($id,widget) ""
rename $textUndoer($id,originalCommand) $textUndoer($id,widget)
delete lifo $textUndoer($id,commandStack)
delete lifo $textUndoer($id,cursorStack)
}
proc textUndoer__checkpoint {id arguments} {
global textUndoer
# do nothing if non modifying command
if {[string compare [lindex $arguments 0] insert]==0} {
textUndoer__processInsertion $id [lrange $arguments 1 end]
}
if {[string compare [lindex $arguments 0] delete]==0} {
textUndoer__processDeletion $id [lrange $arguments 1 end]
}
}
proc textUndoer__processInsertion {id arguments} {
global textUndoer
set number [llength $arguments]
set length 0
# calculate total insertion length while skipping tags in arguments
for {set index 1} {$index<$number} {incr index 2} {
incr length [string length [lindex $arguments $index]]
}
if {$length>0} {
set index [$textUndoer($id,originalCommand) index [lindex $arguments 0]]
lifo__push $textUndoer($id,commandStack) "delete $index $index+${length}c"
lifo__push $textUndoer($id,cursorStack) [$textUndoer($id,originalCommand) index insert]
}
}
proc textUndoer__processDeletion {id arguments} {
global textUndoer
set command $textUndoer($id,originalCommand)
lifo__push $textUndoer($id,cursorStack) [$command index insert]
set start [$command index [lindex $arguments 0]]
if {[llength $arguments]>1} {
lifo__push $textUndoer($id,commandStack) "insert $start {[$command get $start [lindex $arguments 1]]}"
} else {
lifo__push $textUndoer($id,commandStack) "insert $start {[$command get $start]}"
}
}
proc textUndoer__undo {id} {
global _db
bug trying to escape undo... ($_db(undo,disable))
if $_db(undo,disable) {return}
global textUndoer
if {[catch {set cursor [lifo__pop $textUndoer($id,cursorStack)]}]} {
return
}
eval $textUndoer($id,originalCommand) [lifo__pop $textUndoer($id,commandStack)]
# now restore cursor position
$textUndoer($id,originalCommand) mark set insert $cursor
# make sure insertion point can be seen
$textUndoer($id,originalCommand) see insert
}
proc textUndoer__reset {id} {
global textUndoer
lifo__empty $textUndoer($id,commandStack)
lifo__empty $textUndoer($id,cursorStack)
}
|