1# tooltip.tcl -- 2# 3# Balloon help 4# 5# Copyright (c) 1996-2007 Jeffrey Hobbs 6# 7# See the file "license.terms" for information on usage and redistribution 8# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9# 10# RCS: @(#) $Id: tooltip.tcl,v 1.16 2008/12/01 23:37:16 hobbs Exp $ 11# 12# Initiated: 28 October 1996 13 14 15package require Tk 8.4 16package require msgcat 17 18#------------------------------------------------------------------------ 19# PROCEDURE 20# tooltip::tooltip 21# 22# DESCRIPTION 23# Implements a tooltip (balloon help) system 24# 25# ARGUMENTS 26# tooltip <option> ?arg? 27# 28# clear ?pattern? 29# Stops the specified widgets (defaults to all) from showing tooltips 30# 31# delay ?millisecs? 32# Query or set the delay. The delay is in milliseconds and must 33# be at least 50. Returns the delay. 34# 35# disable OR off 36# Disables all tooltips. 37# 38# enable OR on 39# Enables tooltips for defined widgets. 40# 41# <widget> ?-index index? ?-items id? ?-tag tag? ?message? 42# If -index is specified, then <widget> is assumed to be a menu 43# and the index represents what index into the menu (either the 44# numerical index or the label) to associate the tooltip message with. 45# Tooltips do not appear for disabled menu items. 46# If -item is specified, then <widget> is assumed to be a listbox 47# or canvas and the itemId specifies one or more items. 48# If -tag is specified, then <widget> is assumed to be a text 49# and the tagId specifies a tag. 50# If message is {}, then the tooltip for that widget is removed. 51# The widget must exist prior to calling tooltip. The current 52# tooltip message for <widget> is returned, if any. 53# 54# RETURNS: varies (see methods above) 55# 56# NAMESPACE & STATE 57# The namespace tooltip is used. 58# Control toplevel name via ::tooltip::wname. 59# 60# EXAMPLE USAGE: 61# tooltip .button "A Button" 62# tooltip .menu -index "Load" "Loads a file" 63# 64#------------------------------------------------------------------------ 65 66namespace eval ::tooltip { 67 namespace export -clear tooltip 68 variable labelOpts 69 variable tooltip 70 variable G 71 72 if {![info exists G]} { 73 array set G { 74 enabled 1 75 fade 1 76 FADESTEP 0.2 77 FADEID {} 78 DELAY 500 79 AFTERID {} 80 LAST -1 81 TOPLEVEL .__tooltip__ 82 } 83 if {[tk windowingsystem] eq "x11"} { 84 set G(fade) 0 ; # don't fade by default on X11 85 } 86 } 87 if {![info exists labelOpts]} { 88 # Undocumented variable that allows users to extend / override 89 # label creation options. Must be set prior to first registry 90 # of a tooltip, or destroy $::tooltip::G(TOPLEVEL) first. 91 set labelOpts [list -highlightthickness 0 -relief solid -bd 1 \ 92 -background lightyellow -fg black] 93 } 94 95 # The extra ::hide call in <Enter> is necessary to catch moving to 96 # child widgets where the <Leave> event won't be generated 97 bind Tooltip <Enter> [namespace code { 98 #tooltip::hide 99 variable tooltip 100 variable G 101 set G(LAST) -1 102 if {$G(enabled) && [info exists tooltip(%W)]} { 103 set G(AFTERID) \ 104 [after $G(DELAY) [namespace code [list show %W $tooltip(%W) cursor]]] 105 } 106 }] 107 108 bind Menu <<MenuSelect>> [namespace code { menuMotion %W }] 109 bind Tooltip <Leave> [namespace code [list hide 1]] ; # fade ok 110 bind Tooltip <Any-KeyPress> [namespace code hide] 111 bind Tooltip <Any-Button> [namespace code hide] 112} 113 114proc ::tooltip::tooltip {w args} { 115 variable tooltip 116 variable G 117 switch -- $w { 118 clear { 119 if {[llength $args]==0} { set args .* } 120 clear $args 121 } 122 delay { 123 if {[llength $args]} { 124 if {![string is integer -strict $args] || $args<50} { 125 return -code error "tooltip delay must be an\ 126 integer greater than 50 (delay is in millisecs)" 127 } 128 return [set G(DELAY) $args] 129 } else { 130 return $G(DELAY) 131 } 132 } 133 fade { 134 if {[llength $args]} { 135 set G(fade) [string is true -strict [lindex $args 0]] 136 } 137 return $G(fade) 138 } 139 off - disable { 140 set G(enabled) 0 141 hide 142 } 143 on - enable { 144 set G(enabled) 1 145 } 146 default { 147 set i $w 148 if {[llength $args]} { 149 set i [uplevel 1 [namespace code "register [list $w] $args"]] 150 } 151 set b $G(TOPLEVEL) 152 if {![winfo exists $b]} { 153 variable labelOpts 154 155 toplevel $b -class Tooltip 156 if {[tk windowingsystem] eq "aqua"} { 157 ::tk::unsupported::MacWindowStyle style $b help none 158 } else { 159 wm overrideredirect $b 1 160 } 161 catch {wm attributes $b -topmost 1} 162 # avoid the blink issue with 1 to <1 alpha on Windows 163 catch {wm attributes $b -alpha 0.99} 164 wm positionfrom $b program 165 wm withdraw $b 166 eval [linsert $labelOpts 0 label $b.label] 167 pack $b.label -ipadx 1 168 } 169 if {[info exists tooltip($i)]} { return $tooltip($i) } 170 } 171 } 172} 173 174proc ::tooltip::register {w args} { 175 variable tooltip 176 set key [lindex $args 0] 177 while {[string match -* $key]} { 178 switch -- $key { 179 -index { 180 if {[catch {$w entrycget 1 -label}]} { 181 return -code error "widget \"$w\" does not seem to be a\ 182 menu, which is required for the -index switch" 183 } 184 set index [lindex $args 1] 185 set args [lreplace $args 0 1] 186 } 187 -item - -items { 188 if {[winfo class $w] eq "Listbox"} { 189 set items [lindex $args 1] 190 } else { 191 set namedItem [lindex $args 1] 192 if {[catch {$w find withtag $namedItem} items]} { 193 return -code error "widget \"$w\" is not a canvas, or\ 194 item \"$namedItem\" does not exist in the canvas" 195 } 196 } 197 set args [lreplace $args 0 1] 198 } 199 -tag { 200 set tag [lindex $args 1] 201 set r [catch {lsearch -exact [$w tag names] $tag} ndx] 202 if {$r || $ndx == -1} { 203 return -code error "widget \"$w\" is not a text widget or\ 204 \"$tag\" is not a text tag" 205 } 206 set args [lreplace $args 0 1] 207 } 208 default { 209 return -code error "unknown option \"$key\":\ 210 should be -index, -items or -tag" 211 } 212 } 213 set key [lindex $args 0] 214 } 215 if {[llength $args] != 1} { 216 return -code error "wrong # args: should be \"tooltip widget\ 217 ?-index index? ?-items item? ?-tag tag? message\"" 218 } 219 if {$key eq ""} { 220 clear $w 221 } else { 222 if {![winfo exists $w]} { 223 return -code error "bad window path name \"$w\"" 224 } 225 if {[info exists index]} { 226 set tooltip($w,$index) $key 227 return $w,$index 228 } elseif {[info exists items]} { 229 foreach item $items { 230 set tooltip($w,$item) $key 231 if {[winfo class $w] eq "Listbox"} { 232 enableListbox $w $item 233 } else { 234 enableCanvas $w $item 235 } 236 } 237 # Only need to return the first item for the purposes of 238 # how this is called 239 return $w,[lindex $items 0] 240 } elseif {[info exists tag]} { 241 set tooltip($w,t_$tag) $key 242 enableTag $w $tag 243 return $w,$tag 244 } else { 245 set tooltip($w) $key 246 bindtags $w [linsert [bindtags $w] end "Tooltip"] 247 return $w 248 } 249 } 250} 251 252proc ::tooltip::clear {{pattern .*}} { 253 variable tooltip 254 # cache the current widget at pointer 255 set ptrw [winfo containing [winfo pointerx .] [winfo pointery .]] 256 foreach w [array names tooltip $pattern] { 257 unset tooltip($w) 258 if {[winfo exists $w]} { 259 set tags [bindtags $w] 260 if {[set i [lsearch -exact $tags "Tooltip"]] != -1} { 261 bindtags $w [lreplace $tags $i $i] 262 } 263 ## We don't remove TooltipMenu because there 264 ## might be other indices that use it 265 266 # Withdraw the tooltip if we clear the current contained item 267 if {$ptrw eq $w} { hide } 268 } 269 } 270} 271 272proc ::tooltip::show {w msg {i {}}} { 273 if {![winfo exists $w]} { return } 274 275 # Use string match to allow that the help will be shown when 276 # the pointer is in any child of the desired widget 277 if {([winfo class $w] ne "Menu") 278 && ![string match $w* [eval [list winfo containing] \ 279 [winfo pointerxy $w]]]} { 280 return 281 } 282 283 variable G 284 285 after cancel $G(FADEID) 286 set b $G(TOPLEVEL) 287 # Use late-binding msgcat (lazy translation) to support programs 288 # that allow on-the-fly l10n changes 289 $b.label configure -text [::msgcat::mc $msg] -justify left 290 update idletasks 291 set screenw [winfo screenwidth $w] 292 set screenh [winfo screenheight $w] 293 set reqw [winfo reqwidth $b] 294 set reqh [winfo reqheight $b] 295 # When adjusting for being on the screen boundary, check that we are 296 # near the "edge" already, as Tk handles multiple monitors oddly 297 if {$i eq "cursor"} { 298 set y [expr {[winfo pointery $w]+20}] 299 if {($y < $screenh) && ($y+$reqh) > $screenh} { 300 set y [expr {[winfo pointery $w]-$reqh-5}] 301 } 302 } elseif {$i ne ""} { 303 set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[$w yposition $i]+25}] 304 if {($y < $screenh) && ($y+$reqh) > $screenh} { 305 # show above if we would be offscreen 306 set y [expr {[winfo rooty $w]+[$w yposition $i]-$reqh-5}] 307 } 308 } else { 309 set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[winfo height $w]+5}] 310 if {($y < $screenh) && ($y+$reqh) > $screenh} { 311 # show above if we would be offscreen 312 set y [expr {[winfo rooty $w]-$reqh-5}] 313 } 314 } 315 if {$i eq "cursor"} { 316 set x [winfo pointerx $w] 317 } else { 318 set x [expr {[winfo rootx $w]+[winfo vrootx $w]+ 319 ([winfo width $w]-$reqw)/2}] 320 } 321 # only readjust when we would appear right on the screen edge 322 if {$x<0 && ($x+$reqw)>0} { 323 set x 0 324 } elseif {($x < $screenw) && ($x+$reqw) > $screenw} { 325 set x [expr {$screenw-$reqw}] 326 } 327 if {[tk windowingsystem] eq "aqua"} { 328 set focus [focus] 329 } 330 # avoid the blink issue with 1 to <1 alpha on Windows, watch half-fading 331 catch {wm attributes $b -alpha 0.99} 332 wm geometry $b +$x+$y 333 wm deiconify $b 334 raise $b 335 if {[tk windowingsystem] eq "aqua" && $focus ne ""} { 336 # Aqua's help window steals focus on display 337 after idle [list focus -force $focus] 338 } 339} 340 341proc ::tooltip::menuMotion {w} { 342 variable G 343 344 if {$G(enabled)} { 345 variable tooltip 346 347 # Menu events come from a funny path, map to the real path. 348 set m [string map {"#" "."} [winfo name $w]] 349 set cur [$w index active] 350 351 # The next two lines (all uses of LAST) are necessary until the 352 # <<MenuSelect>> event is properly coded for Unix/(Windows)? 353 if {$cur == $G(LAST)} return 354 set G(LAST) $cur 355 # a little inlining - this is :hide 356 after cancel $G(AFTERID) 357 catch {wm withdraw $G(TOPLEVEL)} 358 if {[info exists tooltip($m,$cur)] || \ 359 (![catch {$w entrycget $cur -label} cur] && \ 360 [info exists tooltip($m,$cur)])} { 361 set G(AFTERID) [after $G(DELAY) \ 362 [namespace code [list show $w $tooltip($m,$cur) cursor]]] 363 } 364 } 365} 366 367proc ::tooltip::hide {{fadeOk 0}} { 368 variable G 369 370 after cancel $G(AFTERID) 371 after cancel $G(FADEID) 372 if {$fadeOk && $G(fade)} { 373 fade $G(TOPLEVEL) $G(FADESTEP) 374 } else { 375 catch {wm withdraw $G(TOPLEVEL)} 376 } 377} 378 379proc ::tooltip::fade {w step} { 380 if {[catch {wm attributes $w -alpha} alpha] || $alpha <= 0.0} { 381 catch { wm withdraw $w } 382 catch { wm attributes $w -alpha 0.99 } 383 } else { 384 variable G 385 wm attributes $w -alpha [expr {$alpha-$step}] 386 set G(FADEID) [after 50 [namespace code [list fade $w $step]]] 387 } 388} 389 390proc ::tooltip::wname {{w {}}} { 391 variable G 392 if {[llength [info level 0]] > 1} { 393 # $w specified 394 if {$w ne $G(TOPLEVEL)} { 395 hide 396 destroy $G(TOPLEVEL) 397 set G(TOPLEVEL) $w 398 } 399 } 400 return $G(TOPLEVEL) 401} 402 403proc ::tooltip::listitemTip {w x y} { 404 variable tooltip 405 variable G 406 407 set G(LAST) -1 408 set item [$w index @$x,$y] 409 if {$G(enabled) && [info exists tooltip($w,$item)]} { 410 set G(AFTERID) [after $G(DELAY) \ 411 [namespace code [list show $w $tooltip($w,$item) cursor]]] 412 } 413} 414 415# Handle the lack of <Enter>/<Leave> between listbox items using <Motion> 416proc ::tooltip::listitemMotion {w x y} { 417 variable tooltip 418 variable G 419 if {$G(enabled)} { 420 set item [$w index @$x,$y] 421 if {$item ne $G(LAST)} { 422 set G(LAST) $item 423 after cancel $G(AFTERID) 424 catch {wm withdraw $G(TOPLEVEL)} 425 if {[info exists tooltip($w,$item)]} { 426 set G(AFTERID) [after $G(DELAY) \ 427 [namespace code [list show $w $tooltip($w,$item) cursor]]] 428 } 429 } 430 } 431} 432 433# Initialize tooltip events for Listbox widgets 434proc ::tooltip::enableListbox {w args} { 435 if {[string match *listitemTip* [bind $w <Enter>]]} { return } 436 bind $w <Enter> +[namespace code [list listitemTip %W %x %y]] 437 bind $w <Motion> +[namespace code [list listitemMotion %W %x %y]] 438 bind $w <Leave> +[namespace code [list hide 1]] ; # fade ok 439 bind $w <Any-KeyPress> +[namespace code hide] 440 bind $w <Any-Button> +[namespace code hide] 441} 442 443proc ::tooltip::itemTip {w args} { 444 variable tooltip 445 variable G 446 447 set G(LAST) -1 448 set item [$w find withtag current] 449 if {$G(enabled) && [info exists tooltip($w,$item)]} { 450 set G(AFTERID) [after $G(DELAY) \ 451 [namespace code [list show $w $tooltip($w,$item) cursor]]] 452 } 453} 454 455proc ::tooltip::enableCanvas {w args} { 456 if {[string match *itemTip* [$w bind all <Enter>]]} { return } 457 $w bind all <Enter> +[namespace code [list itemTip $w]] 458 $w bind all <Leave> +[namespace code [list hide 1]] ; # fade ok 459 $w bind all <Any-KeyPress> +[namespace code hide] 460 $w bind all <Any-Button> +[namespace code hide] 461} 462 463proc ::tooltip::tagTip {w tag} { 464 variable tooltip 465 variable G 466 set G(LAST) -1 467 if {$G(enabled) && [info exists tooltip($w,t_$tag)]} { 468 if {[info exists G(AFTERID)]} { after cancel $G(AFTERID) } 469 set G(AFTERID) [after $G(DELAY) \ 470 [namespace code [list show $w $tooltip($w,t_$tag) cursor]]] 471 } 472} 473 474proc ::tooltip::enableTag {w tag} { 475 if {[string match *tagTip* [$w tag bind $tag]]} { return } 476 $w tag bind $tag <Enter> +[namespace code [list tagTip $w $tag]] 477 $w tag bind $tag <Leave> +[namespace code [list hide 1]] ; # fade ok 478 $w tag bind $tag <Any-KeyPress> +[namespace code hide] 479 $w tag bind $tag <Any-Button> +[namespace code hide] 480} 481 482package provide tooltip 1.4.4 483