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
|
# balloon.tcl --
#
# This file is a part of the Tkabber XMPP client. It implements
# floating balloon help windows.
option add *Balloon*background LightYellow widgetDefault
option add *Balloon*foreground Black widgetDefault
option add *Balloon.style delay widgetDefault
option add *Balloon.text.padX 0.5m widgetDefault
option add *Balloon.text.padY 0.5m widgetDefault
toplevel .balloon -borderwidth 0 -class Balloon
bind .balloon <Any-Motion> \
[list balloon::default_balloon .balloon leave %X %Y]
pack [message .balloon.text -text "" \
-aspect 5000 \
-width 0 \
-relief solid \
-borderwidth 0.25m]
if {$::tcl_platform(platform) == "macintosh"} {
catch { unsupported1 style .balloon floating sideTitlebar }
} elseif {$::aquaP} {
::tk::unsupported::MacWindowStyle style .balloon help none
} else {
wm transient .balloon .
}
wm withdraw .balloon
namespace eval balloon {
variable _id ""
variable _delay 600
variable _cur ""
variable balloon_showed 0
variable balloon_remove 0
variable style [option get .balloon style Balloon]
}
proc balloon::set_text {text args} {
if {[.balloon.text cget -text] eq $text} return
set width 0
set aspect 5000
foreach {opt val} $args {
switch -- $opt {
-width { set width $val }
-aspect { set aspect $val }
}
}
after idle [list .balloon.text configure -text $text \
-aspect $aspect \
-width $width]
}
proc balloon::show {mx my} {
variable balloon_showed
variable balloon_remove
variable max_bx
if {[.balloon.text cget -text] == ""} {
balloon::destroy
return
}
set balloon_showed 1
set balloon_remove 0
set b_w [winfo reqwidth .balloon]
set b_h [winfo reqheight .balloon]
if {$::tcl_platform(platform) == "windows" && \
($mx >= [winfo screenwidth .] || $my >= [winfo screenheight .] ||
$mx < 0 || $my < 0)} {
set b_x [expr {$mx + 1}]
set b_y [expr {$my + 1}]
} else {
set max_bx [expr {[winfo screenwidth .] - $b_w}]
set max_by [expr {[winfo screenheight .] - $b_h}]
set b_x [expr {$mx + [winfo pixels .balloon 3m]}]
set b_y [expr {$my + [winfo pixels .balloon 4m]}]
set b_x [::tcl::mathfunc::max [::tcl::mathfunc::min $b_x $max_bx] 0]
set b_y [::tcl::mathfunc::max [::tcl::mathfunc::min $b_y $max_by] 0]
if {($mx >= $b_x) && ($mx <= $b_x+$b_w)} {
if {($my >= $b_y) && ($my <= $b_y+$b_h)} {
set b_y1 [expr {$my - 5 - $b_h}]
if {$b_y1 >= 0} {
set b_y $b_y1
}
}
set max_bx [::tcl::mathfunc::max $max_bx $b_h]
if {$b_x < $max_bx && $b_x <= $mx + [winfo pixels .balloon 3m] && $b_w <= $max_bx} {
set b_x [expr {$mx + [winfo pixels .balloon 3m]}]
}
}
}
wm overrideredirect .balloon 1
wm geometry .balloon +$b_x+$b_y
wm deiconify .balloon
# need the raise in case we're ballooning over a detached menu (emoticons)
raise .balloon
}
proc balloon::set_delay {w mx my} {
global tcl_platform
variable balloon_showed
variable balloon_remove
variable _id
variable _delay
variable _cur
if {$_cur != $w} {
if {$_id != ""} {
after cancel $_id
}
set _id [after $_delay "balloon::show $mx $my"]
set _cur $w
wm withdraw .balloon
if {$tcl_platform(platform) == "unix"} {
wm overrideredirect .balloon 0
}
set balloon_showed 0
set balloon_remove 0
} else {
set balloon_remove 0
if {$balloon_showed == 0} {
if {$_id != ""} {
after cancel $_id
}
set _id [after $_delay "balloon::show $mx $my"]
}
}
}
proc balloon::on_mouse_move {w mx my} {
variable style
switch -- $style {
delay {set_delay $w $mx $my}
follow {show $mx $my}
}
}
proc balloon::destroy {} {
global tcl_platform
variable balloon_showed
variable balloon_remove
variable _id
if {$_id != ""} {
after cancel $_id
set _id ""
}
set balloon_remove 1
after 100 {
if {$::balloon::balloon_remove} {
wm withdraw .balloon
if {$::tcl_platform(platform) == "unix"} {
wm overrideredirect .balloon 0
}
set ::balloon::balloon_showed 0
set ::balloon::balloon_remove 0
}
}
}
proc balloon::default_balloon {w action X Y args} {
set sw $w
set text ""
set command ""
set newargs $args
# $args may contain odd number of members, so a bit unusual parsing
set idx 0
foreach {opt val} $args {
switch -- $opt {
-text {
set text $val
set newargs [lreplace $newargs $idx [expr {$idx + 1}]]
}
-command {
set command $val
set newargs [lreplace $newargs $idx [expr {$idx + 1}]]
}
default {
incr idx 2
}
}
}
if {$command != ""} {
set newargs [lassign [{*}$command {*}$newargs] sw text]
}
switch -- $action {
enter {
balloon::set_text $text {*}$newargs
}
motion {
balloon::set_text $text {*}$newargs
balloon::on_mouse_move $sw $X $Y
}
leave {
balloon::destroy
}
}
}
proc balloon::setup {w args} {
# Try to bind in Tree widget
if {![catch {
$w bindText <Any-Enter> \
[list [namespace current]::default_balloon %W enter %X %Y \
{*}[double% $args]]
}]} {
$w bindText <Any-Motion> \
[list [namespace current]::default_balloon %W motion %X %Y \
{*}[double% $args]]
$w bindText <Any-Leave> \
[list balloon::default_balloon %W leave %X %Y]
} else {
bind $w <Any-Enter> \
[list [namespace current]::default_balloon %W enter %X %Y \
{*}[double% $args]]
bind $w <Any-Motion> \
[list [namespace current]::default_balloon %W motion %X %Y \
{*}[double% $args]]
bind $w <Any-Leave> \
[list balloon::default_balloon %W leave %X %Y]
}
}
# vim:ft=tcl:ts=8:sw=4:sts=4:et
|
