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