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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
|
# $Id: widgetip.tcl,v 2.18 2005/01/30 19:15:39 jfontain Exp $
class widgetTip {
variable screenWidth [winfo screenwidth .]
variable screenHeight [winfo screenheight .]
variable xOffset 7
variable yOffset 10
class topLabel {
proc topLabel {this parentPath args} composite {
[new toplevel $parentPath -highlightbackground black -highlightthickness 1] $args
} {
composite::manage $this [new label $widget::($this,path) -justify left] label
composite::complete $this
pack $composite::($this,label,path)
wm overrideredirect $widget::($this,path) 1 ;# no window manager decorations
}
proc ~topLabel {this} {}
proc options {this} {
return [list\
[list -bordercolor Black Black]\
[list -borderwidth 1 1]\
[list -background $widget::option(button,background) $widget::option(button,background)]\
[list -font $widget::option(button,font) $widget::option(button,font)]\
[list -foreground $widget::option(button,foreground) $widget::option(button,foreground)]\
[list -text {} {}]\
[list -wraplength 400]\
]
}
foreach option {-background -font -foreground -text -wraplength} {
proc set$option {this value} "\$composite::(\$this,label,path) configure $option \$value"
}
proc set-bordercolor {this value} {
$widget::($this,path) configure -highlightbackground $value
}
proc set-borderwidth {this value} {
$widget::($this,path) configure -highlightthickness $value
}
}
if {![info exists (label)]} {
set (label) [new topLabel . -font $widget::option(entry,font) -background #FFFFDF]
set (path) $widget::($(label),path)
wm withdraw $(path)
# handle button and key presses as global events for some child widgets (such as entries) do not pass them to their parent
bind all <ButtonPress> {widgetTip::globalEvent %W}
bind all <KeyPress> {widgetTip::globalEvent %W}
set (xLast) -1
set (yLast) -1
}
proc widgetTip {this args} switched {$args} {
switched::complete $this
setupBindings $this
}
proc ~widgetTip {this} {
catch {after cancel $($this,event)}
if {!$switched::($this,-ephemeral)} { ;# avoid infinite loop since ephemeral tip deletes self when first disabled
disable $this
}
if {[info exists ($this,bindings)]} { ;# remove bindings if any
delete $($this,bindings)
}
set path $switched::($this,-path)
set tag $switched::($this,-itemortag)
if {([string length $path] > 0) && ([string length $tag] > 0)} { ;# remove canvas bindings
array set match [list <Enter> "widgetTip::enable $this" <Leave> "widgetTip::disable $this"]
foreach sequence [array names match] {
set script {}
foreach line [split [$path bind $tag $sequence] \n] {
if {![string equal [string trim $line] $match($sequence)]} {
if {[string length $script] > 0} {append script \n}
append script $line
}
}
$path bind $tag $sequence $script ;# restore original binding script
}
}
}
proc options {this} {
return [list\
[list -ephemeral 0 0]\
[list -font $widget::option(entry,font) $widget::option(entry,font)]\
[list -itemortag {} {}]\
[list -path {} {}]\
[list -rectangle {} {}]\
[list -state normal normal]\
[list -text {} {}]\
]
}
proc set-ephemeral {this value} {
if {$switched::($this,complete)} {
error {option -ephemeral cannot be set dynamically}
}
}
proc set-itemortag {this value} { ;# implies that tip cannot be deleted before the canvas that it applies to
if {$switched::($this,complete)} {
error {option -itemortag cannot be set dynamically}
}
if {[string length $switched::($this,-rectangle)] > 0} {
error {-itemortag and -rectangle options are incompatible}
}
if {([string length $switched::($this,-path)] > 0) && [catch {$switched::($this,-path) type $value} message]} {
error "$switched::($this,-path) is not a canvas, $value not a valid item or tag, ...: $message"
}
}
proc set-path {this value} {
if {$switched::($this,complete)} {
error {option -path cannot be set dynamically}
}
if {![winfo exists $value]} {
error "invalid widget: \"$value\""
}
if {([string length $switched::($this,-itemortag)] > 0) && [catch {$value type $switched::($this,-itemortag)} message]} {
error "$value is not a canvas, $switched::($this,-itemortag) not a valid item or tag, ...: $message"
}
}
proc set-rectangle {this value} {
if {[string length $switched::($this,-itemortag)] > 0} {
error {-itemortag and -rectangle options are incompatible}
}
set error 0
if {[llength $value] != 4} {
set error 1
} else {
foreach item $value {
if {![string is integer -strict $item]} {set error 1; break}
}
}
if {$error} {
error {-rectangle option must be a list of 4 integers}
}
foreach [list ($this,left) ($this,top) ($this,right) ($this,bottom)] $value {}
setupBindings $this
if {[string length $switched::($this,-path)] > 0} { ;# generate an artificial motion event for correctness
set path $switched::($this,-path)
after idle widgetTip::motion $this [expr {[winfo pointerx $path] - [winfo rootx $path]}]\
[expr {[winfo pointery $path] - [winfo rooty $path]}] ;# wait after object is completely constructed
}
}
proc set-state {this value} {
switch $value {
disabled {disable $this}
normal {}
default {error "bad state value \"$value\": must be normal or disabled"}
}
}
proc setupBindings {this} { ;# invoked right after completion
if {[string length $switched::($this,-itemortag)] == 0} {
if {![info exists ($this,bindings)]} { ;# may be invoked several times when setting -rectangle option
set ($this,bindings) [new bindings $switched::($this,-path) 0]
}
if {[string length $switched::($this,-rectangle)] > 0} {
bindings::set $($this,bindings) <Enter> {} ;# possibly reset existing binding for -path
bindings::set $($this,bindings) <Leave> "widgetTip::disable $this; catch {unset widgetTip::($this,in)}"
bindings::set $($this,bindings) <Motion> "widgetTip::motion $this %x %y"
} else {
bindings::set $($this,bindings) <Enter> "widgetTip::enable $this"
bindings::set $($this,bindings) <Leave> "widgetTip::disable $this"
}
} else {
$switched::($this,-path) bind $switched::($this,-itemortag) <Enter> "+ widgetTip::enable $this"
$switched::($this,-path) bind $switched::($this,-itemortag) <Leave> "+ widgetTip::disable $this"
}
}
proc set-font {this value} {} ;# nothing to do, data is saved at switched level
proc set-text {this value} {
if {[info exists (active)] && ($(active) == $this)} {
widget::configure $(label) -text $value ;# update tip label
}
}
proc globalEvent {widget} {
if {![catch {string first $switched::($(active),-path) $widget} value] && ($value == 0)} {
disable $(active) ;# hide if active widget exists and is a descendant of the active target widget
}
}
proc show {this x y} { ;# pointer screen coordinates
variable screenWidth
variable screenHeight
variable xOffset
variable yOffset
set path $(path)
widget::configure $(label) -font $switched::($this,-font) -text $switched::($this,-text) ;# update tip label
update idletasks ;# make sure sizes are correct
set size [winfo reqwidth $path]
set delta [expr {$screenWidth - $x - $xOffset - $size}]
if {$delta < 0} { ;# widget tip right edge would be pass screen: position widget right edge left of pointer
incr x -$xOffset
incr x -$size
} else {
incr x $xOffset
}
set size [winfo reqheight $path]
set delta [expr {$screenHeight - $y - $yOffset - $size}]
if {$delta < 0} { ;# widget tip bottom edge would be pass screen: position widget bottom edge above pointer
incr y -$yOffset
incr y -$size
} else {
incr y $yOffset
}
showTopLevel $path +$x+$y
update idletasks
raise $path
}
proc enable {this} {
if {[catch {classof $this}]} return ;# has been deleted already
if {[string equal $switched::($this,-state) disabled] || ([string length $switched::($this,-text)] == 0)} {
return ;# nothing to display
}
set x [winfo pointerx $(path)]
set y [winfo pointery $(path)]
if {($x == $(xLast)) && ($y == $(yLast))} {
catch {after cancel $($this,event)}
show $this $x $y
} else {
set (xLast) $x
set (yLast) $y
set ($this,event) [after 300 "widgetTip::enable $this"] ;# poll
}
set (active) $this ;# remember active object
}
proc disable {this} {
# event and active tip may no longer exist when the pointer leaves after a click (for example)
catch {after cancel $($this,event)}
catch {unset (active)}
wm withdraw $(path)
if {$switched::($this,-ephemeral)} {after idle "if {!\[catch {classof $this}\]} {delete $this}"}
}
proc motion {this x y} {
if {[catch {classof $this}]} return ;# has been deleted already
if {($x < $($this,left)) || ($y < $($this,top)) || ($x > $($this,right)) || ($y > $($this,bottom))} { ;# out of rectangle
if {[info exists ($this,in)]} { ;# just crossed rectangle border
unset ($this,in)
disable $this
}
} else { ;# in rectangle
if {![info exists ($this,in)]} { ;# just crossed rectangle border
set ($this,in) {}
enable $this
}
}
}
}
|
