Scid  4.6.5
tklib_tooltip.tcl
Go to the documentation of this file.
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 
15 package require Tk 8.4
16 package 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 
66 namespace 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 
114 proc ::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 
174 proc ::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  break
210  }
211  }
212  set key [lindex $args 0]
213  }
214  if {[llength $args] != 1} {
215  return -code error "wrong # args: should be \"tooltip widget\
216  ?-index index? ?-items item? ?-tag tag? message\""
217  }
218  if {$key eq ""} {
219  clear $w
220  } else {
221  if {![winfo exists $w]} {
222  return -code error "bad window path name \"$w\""
223  }
224  if {[info exists index]} {
225  set tooltip($w,$index) $key
226  return $w,$index
227  } elseif {[info exists items]} {
228  foreach item $items {
229  set tooltip($w,$item) $key
230  if {[winfo class $w] eq "Listbox"} {
231  enableListbox $w $item
232  } else {
233  enableCanvas $w $item
234  }
235  }
236  # Only need to return the first item for the purposes of
237  # how this is called
238  return $w,[lindex $items 0]
239  } elseif {[info exists tag]} {
240  set tooltip($w,t_$tag) $key
241  enableTag $w $tag
242  return $w,$tag
243  } else {
244  set tooltip($w) $key
245  # Note: Add the necessary bindings only once.
246  set tags [bindtags $w]
247  if {[lsearch -exact $tags "Tooltip"] == -1} {
248  bindtags $w [linsert $tags end "Tooltip"]
249  }
250  return $w
251  }
252  }
253 }
254 
255 proc ::tooltip::clear {{pattern .*}} {
256  variable tooltip
257  # cache the current widget at pointer
258  set ptrw [winfo containing [winfo pointerx .] [winfo pointery .]]
259  foreach w [array names tooltip $pattern] {
260  unset tooltip($w)
261  if {[winfo exists $w]} {
262  set tags [bindtags $w]
263  if {[set i [lsearch -exact $tags "Tooltip"]] != -1} {
264  bindtags $w [lreplace $tags $i $i]
265  }
266  ## We don't remove TooltipMenu because there
267  ## might be other indices that use it
268 
269  # Withdraw the tooltip if we clear the current contained item
270  if {$ptrw eq $w} { hide}
271  }
272  }
273 }
274 
275 proc ::tooltip::show {w msg {i {}}} {
276  if {![winfo exists $w]} { return}
277 
278  # Use string match to allow that the help will be shown when
279  # the pointer is in any child of the desired widget
280  if {([winfo class $w] ne "Menu")
281  && ![string match $w* [eval [list winfo containing] \
282  [winfo pointerxy $w]]]} {
283  return
284  }
285 
286  variable G
287 
288  after cancel $G(FADEID)
289  set b $G(TOPLEVEL)
290  # Use late-binding msgcat (lazy translation) to support programs
291  # that allow on-the-fly l10n changes
292  $b.label configure -text [::msgcat::mc $msg] -justify left
293  update idletasks
294  set screenw [winfo screenwidth $w]
295  set screenh [winfo screenheight $w]
296  set reqw [winfo reqwidth $b]
297  set reqh [winfo reqheight $b]
298  # When adjusting for being on the screen boundary, check that we are
299  # near the "edge" already, as Tk handles multiple monitors oddly
300  if {$i eq "cursor"} {
301  set y [expr {[winfo pointery $w]+20}]
302  if {($y < $screenh) && ($y+$reqh) > $screenh} {
303  set y [expr {[winfo pointery $w]-$reqh-5}]
304  }
305  } elseif {$i ne ""} {
306  set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[$w yposition $i]+25}]
307  if {($y < $screenh) && ($y+$reqh) > $screenh} {
308  # show above if we would be offscreen
309  set y [expr {[winfo rooty $w]+[$w yposition $i]-$reqh-5}]
310  }
311  } else {
312  set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[winfo height $w]+5}]
313  if {($y < $screenh) && ($y+$reqh) > $screenh} {
314  # show above if we would be offscreen
315  set y [expr {[winfo rooty $w]-$reqh-5}]
316  }
317  }
318  if {$i eq "cursor"} {
319  set x [winfo pointerx $w]
320  } else {
321  set x [expr {[winfo rootx $w]+[winfo vrootx $w]+
322  ([winfo width $w]-$reqw)/2}]
323  }
324  # only readjust when we would appear right on the screen edge
325  if {$x<0 && ($x+$reqw)>0} {
326  set x 0
327  } elseif {($x < $screenw) && ($x+$reqw) > $screenw} {
328  set x [expr {$screenw-$reqw}]
329  }
330  if {[tk windowingsystem] eq "aqua"} {
331  set focus [focus]
332  }
333  # avoid the blink issue with 1 to <1 alpha on Windows, watch half-fading
334  catch {wm attributes $b -alpha 0.99}
335  wm geometry $b +$x+$y
336  wm deiconify $b
337  raise $b
338  if {[tk windowingsystem] eq "aqua" && $focus ne ""} {
339  # Aqua's help window steals focus on display
340  after idle [list focus -force $focus]
341  }
342 }
343 
344 proc ::tooltip::menuMotion {w} {
345  variable G
346 
347  if {$G(enabled)} {
348  variable tooltip
349 
350  # Menu events come from a funny path, map to the real path.
351  set m [string map {"#" "."} [winfo name $w]]
352  set cur [$w index active]
353 
354  # The next two lines (all uses of LAST) are necessary until the
355  # <<MenuSelect>> event is properly coded for Unix/(Windows)?
356  if {$cur == $G(LAST)} return
357  set G(LAST) $cur
358  # a little inlining - this is :hide
359  after cancel $G(AFTERID)
360  catch {wm withdraw $G(TOPLEVEL)}
361  if {[info exists tooltip($m,$cur)] || \
362  (![catch {$w entrycget $cur -label} cur] && \
363  [info exists tooltip($m,$cur)])} {
364  set G(AFTERID) [after $G(DELAY) \
365  [namespace code [list show $w $tooltip($m,$cur) cursor]]]
366  }
367  }
368 }
369 
370 proc ::tooltip::hide {{fadeOk 0}} {
371  variable G
372 
373  after cancel $G(AFTERID)
374  after cancel $G(FADEID)
375  if {$fadeOk && $G(fade)} {
376  fade $G(TOPLEVEL) $G(FADESTEP)
377  } else {
378  catch {wm withdraw $G(TOPLEVEL)}
379  }
380 }
381 
382 proc ::tooltip::fade {w step} {
383  if {[catch {wm attributes $w -alpha} alpha] || $alpha <= 0.0} {
384  catch { wm withdraw $w}
385  catch { wm attributes $w -alpha 0.99}
386  } else {
387  variable G
388  wm attributes $w -alpha [expr {$alpha-$step}]
389  set G(FADEID) [after 50 [namespace code [list fade $w $step]]]
390  }
391 }
392 
393 proc ::tooltip::wname {{w {}}} {
394  variable G
395  if {[llength [info level 0]] > 1} {
396  # $w specified
397  if {$w ne $G(TOPLEVEL)} {
398  hide
399  destroy $G(TOPLEVEL)
400  set G(TOPLEVEL) $w
401  }
402  }
403  return $G(TOPLEVEL)
404 }
405 
406 proc ::tooltip::listitemTip {w x y} {
407  variable tooltip
408  variable G
409 
410  set G(LAST) -1
411  set item [$w index @$x,$y]
412  if {$G(enabled) && [info exists tooltip($w,$item)]} {
413  set G(AFTERID) [after $G(DELAY) \
414  [namespace code [list show $w $tooltip($w,$item) cursor]]]
415  }
416 }
417 
418 # Handle the lack of <Enter>/<Leave> between listbox items using <Motion>
419 proc ::tooltip::listitemMotion {w x y} {
420  variable tooltip
421  variable G
422  if {$G(enabled)} {
423  set item [$w index @$x,$y]
424  if {$item ne $G(LAST)} {
425  set G(LAST) $item
426  after cancel $G(AFTERID)
427  catch {wm withdraw $G(TOPLEVEL)}
428  if {[info exists tooltip($w,$item)]} {
429  set G(AFTERID) [after $G(DELAY) \
430  [namespace code [list show $w $tooltip($w,$item) cursor]]]
431  }
432  }
433  }
434 }
435 
436 # Initialize tooltip events for Listbox widgets
437 proc ::tooltip::enableListbox {w args} {
438  if {[string match *listitemTip* [bind $w <Enter>]]} { return}
439  bind $w <Enter> +[namespace code [list listitemTip %W %x %y]]
440  bind $w <Motion> +[namespace code [list listitemMotion %W %x %y]]
441  bind $w <Leave> +[namespace code [list hide 1]] ; # fade ok
442  bind $w <Any-KeyPress> +[namespace code hide]
443  bind $w <Any-Button> +[namespace code hide]
444 }
445 
446 proc ::tooltip::itemTip {w args} {
447  variable tooltip
448  variable G
449 
450  set G(LAST) -1
451  set item [$w find withtag current]
452  if {$G(enabled) && [info exists tooltip($w,$item)]} {
453  set G(AFTERID) [after $G(DELAY) \
454  [namespace code [list show $w $tooltip($w,$item) cursor]]]
455  }
456 }
457 
458 proc ::tooltip::enableCanvas {w args} {
459  if {[string match *itemTip* [$w bind all <Enter>]]} { return}
460  $w bind all <Enter> +[namespace code [list itemTip $w]]
461  $w bind all <Leave> +[namespace code [list hide 1]] ; # fade ok
462  $w bind all <Any-KeyPress> +[namespace code hide]
463  $w bind all <Any-Button> +[namespace code hide]
464 }
465 
466 proc ::tooltip::tagTip {w tag} {
467  variable tooltip
468  variable G
469  set G(LAST) -1
470  if {$G(enabled) && [info exists tooltip($w,t_$tag)]} {
471  if {[info exists G(AFTERID)]} { after cancel $G(AFTERID)}
472  set G(AFTERID) [after $G(DELAY) \
473  [namespace code [list show $w $tooltip($w,t_$tag) cursor]]]
474  }
475 }
476 
477 proc ::tooltip::enableTag {w tag} {
478  if {[string match *tagTip* [$w tag bind $tag]]} { return}
479  $w tag bind $tag <Enter> +[namespace code [list tagTip $w $tag]]
480  $w tag bind $tag <Leave> +[namespace code [list hide 1]] ; # fade ok
481  $w tag bind $tag <Any-KeyPress> +[namespace code hide]
482  $w tag bind $tag <Any-Button> +[namespace code hide]
483 }
484 
485 package provide tooltip 1.4.6