Attachment "tooltip.tcl" to
ticket [803a13c9f0]
added by
anonymous
2021-04-14 14:33:51.
# tooltip.tcl --
#
# Balloon help
#
# Copyright (c) 1996-2007 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tooltip.tcl,v 1.16 2008/12/01 23:37:16 hobbs Exp $
#
# Initiated: 28 October 1996
package require Tk 8.6
package require msgcat
#------------------------------------------------------------------------
# PROCEDURE
# tooltip::tooltip
#
# DESCRIPTION
# Implements a tooltip (balloon help) system
#
# ARGUMENTS
# tooltip <option> ?arg?
#
# clear ?pattern?
# Stops the specified widgets (defaults to all) from showing tooltips
#
# delay ?millisecs?
# Query or set the delay. The delay is in milliseconds and must
# be at least 50. Returns the delay.
#
# disable OR off
# Disables all tooltips.
#
# enable OR on
# Enables tooltips for defined widgets.
#
# <widget> ?-index index? ?-items id? ?-tag tag? ?message?
# If -index is specified, then <widget> is assumed to be a menu
# and the index represents what index into the menu (either the
# numerical index or the label) to associate the tooltip message with.
# Tooltips do not appear for disabled menu items.
# If -item is specified, then <widget> is assumed to be a listbox
# or canvas and the itemId specifies one or more items.
# If -tag is specified, then <widget> is assumed to be a text
# and the tagId specifies a tag.
# If message is {}, then the tooltip for that widget is removed.
# The widget must exist prior to calling tooltip. The current
# tooltip message for <widget> is returned, if any.
#
# RETURNS: varies (see methods above)
#
# NAMESPACE & STATE
# The namespace tooltip is used.
# Control toplevel name via ::tooltip::wname.
#
# EXAMPLE USAGE:
# tooltip .button "A Button"
# tooltip .menu -index "Load" "Loads a file"
#
#------------------------------------------------------------------------
# TkTooltipFont is defined in tk library/ttk/fonts.tcl
catch {font create TkTooltipFontItalic}
catch {font configure TkTooltipFontItalic {*}[font configure TkTooltipFont] -slant italic}
namespace eval ::tooltip {
namespace export -clear tooltip
variable opts
variable tooltip
variable G
if {![info exists G]} {
array set G {
enabled 1
fade 1
FADESTEP 0.2
FADEID {}
DELAY 500
AFTERID {}
LAST -1
TOPLEVEL .__tooltip__
}
if {[tk windowingsystem] eq "x11"} {
set G(fade) 0 ; # don't fade by default on X11
}
}
if {![info exists opts]} {
# Undocumented variables that allows users to extend / override
# label creation options. Must be set prior to first registry
# of a tooltip, or destroy $::tooltip::G(TOPLEVEL) first.
set opts(frame) [list -highlightthickness 0 -relief solid -bd 1 \
-background lightyellow]
set opts(label) [list -bd 0 -background lightyellow -fg black\
-padx 1 -pady 1 -font TkTooltipFont]
set opts(info) [list -bd 0 -background lightyellow -fg black\
-padx 3 -pady 3 -font TkTooltipFontItalic]
}
# The extra ::hide call in <Enter> is necessary to catch moving to
# child widgets where the <Leave> event won't be generated
bind Tooltip <Enter> [namespace code {
#tooltip::hide
variable tooltip
variable G
set G(LAST) -1
if {$G(enabled) && [info exists tooltip(%W)]} {
set G(AFTERID) \
[after $G(DELAY) [namespace code [list show %W $tooltip(%W) cursor]]]
}
}]
bind Menu <<MenuSelect>> [namespace code { menuMotion %W }]
bind Tooltip <Leave> [namespace code [list hide 1]] ; # fade ok
bind Tooltip <Any-KeyPress> [namespace code hide]
bind Tooltip <Any-Button> [namespace code hide]
}
proc ::tooltip::tooltip {w args} {
variable tooltip
variable G
switch -- $w {
clear {
if {[llength $args]==0} { set args .* }
clear $args
}
delay {
if {[llength $args]} {
if {![string is integer -strict $args] || $args<50} {
return -code error "tooltip delay must be an\
integer greater than 50 (delay is in millisecs)"
}
return [set G(DELAY) $args]
} else {
return $G(DELAY)
}
}
fade {
if {[llength $args]} {
set G(fade) [string is true -strict [lindex $args 0]]
}
return $G(fade)
}
off - disable {
set G(enabled) 0
hide
}
on - enable {
set G(enabled) 1
}
default {
set i $w
if {[llength $args]} {
set i [uplevel 1 [namespace code "register [list $w] $args"]]
}
set b $G(TOPLEVEL)
if {![winfo exists $b]} {
variable opts
toplevel $b -class Tooltip
if {[tk windowingsystem] eq "aqua"} {
::tk::unsupported::MacWindowStyle style $b help none
} else {
wm overrideredirect $b 1
}
catch {wm attributes $b -topmost 1}
# avoid the blink issue with 1 to <1 alpha on Windows
catch {wm attributes $b -alpha 0.99}
wm positionfrom $b program
wm withdraw $b
frame $b.f {*}$opts(frame)
grid $b.f
grid columnconfigure $b.f 1 -weight 1
label $b.f.label {*}$opts(label) -justify left -compound left
grid $b.f.label -sticky w
label $b.f.info {*}$opts(info) -justify left
grid $b.f.info -sticky w
}
if {[info exists tooltip($i)]} { return $tooltip($i) }
}
}
}
proc ::tooltip::register {w args} {
variable tooltip
set key [lindex $args 0]
set img {}
set inf {}
while {[string match -* $key]} {
switch -- $key {
-- {
set args [lreplace $args 0 0]
set key [lindex $args 0]
break
}
-index {
if {[catch {$w entrycget 1 -label}]} {
return -code error "widget \"$w\" does not seem to be a\
menu, which is required for the -index switch"
}
set index [lindex $args 1]
set args [lreplace $args 0 1]
}
-item - -items {
if {[winfo class $w] eq "Listbox"} {
set items [lindex $args 1]
} else {
set namedItem [lindex $args 1]
if {[catch {$w find withtag $namedItem} items]} {
return -code error "widget \"$w\" is not a canvas, or\
item \"$namedItem\" does not exist in the canvas"
}
}
set args [lreplace $args 0 1]
}
-tag {
set tag [lindex $args 1]
set r [catch {lsearch -exact [$w tag names] $tag} ndx]
if {$r || $ndx == -1} {
return -code error "widget \"$w\" is not a text widget or\
\"$tag\" is not a text tag"
}
set args [lreplace $args 0 1]
}
-image {
set img [lindex $args 1]
set args [lreplace $args 0 1]
}
-info {
set inf [lindex $args 1]
set args [lreplace $args 0 1]
}
default {
return -code error "unknown option \"$key\":\
should be -image, -index, -info, -items, -tag or --"
}
}
set key [lindex $args 0]
}
if {[llength $args] != 1} {
return -code error "wrong # args: should be \"tooltip widget\
?-image image? ?-index index? ?-info info? ?-items item?\
?-tag tag? ?--? message\""
}
if {$key eq ""} {
clear $w
} else {
if {![winfo exists $w]} {
return -code error "bad window path name \"$w\""
}
if {[info exists index]} {
set tooltip($w,$index) [list $key $img $inf]
return $w,$index
} elseif {[info exists items]} {
foreach item $items {
set tooltip($w,$item) [list $key $img $inf]
if {[winfo class $w] eq "Listbox"} {
enableListbox $w $item
} else {
enableCanvas $w $item
}
}
# Only need to return the first item for the purposes of
# how this is called
return $w,[lindex $items 0]
} elseif {[info exists tag]} {
set tooltip($w,t_$tag) [list $key $img $inf]
enableTag $w $tag
return $w,$tag
} else {
set tooltip($w) [list $key $img $inf]
# Note: Add the necessary bindings only once.
set tags [bindtags $w]
if {[lsearch -exact $tags "Tooltip"] == -1} {
bindtags $w [linsert $tags end "Tooltip"]
}
return $w
}
}
}
proc ::tooltip::clear {{pattern .*}} {
variable tooltip
# cache the current widget at pointer
set ptrw [winfo containing [winfo pointerx .] [winfo pointery .]]
foreach w [array names tooltip $pattern] {
unset tooltip($w)
if {[winfo exists $w]} {
set tags [bindtags $w]
if {[set i [lsearch -exact $tags "Tooltip"]] != -1} {
bindtags $w [lreplace $tags $i $i]
}
## We don't remove TooltipMenu because there
## might be other indices that use it
# Withdraw the tooltip if we clear the current contained item
if {$ptrw eq $w} { hide }
}
}
}
proc ::tooltip::show {w msg {i {}}} {
if {![winfo exists $w]} { return }
# Use string match to allow that the help will be shown when
# the pointer is in any child of the desired widget
if {([winfo class $w] ne "Menu")
&& ![string match $w* [eval [list winfo containing] \
[winfo pointerxy $w]]]} {
return
}
variable G
after cancel $G(FADEID)
set b $G(TOPLEVEL)
# Use late-binding msgcat (lazy translation) to support programs
# that allow on-the-fly l10n changes
lassign $msg txt img inf
$b.f.label configure -text [::msgcat::mc $txt] -image $img
if {$inf eq {}} {
grid remove $b.f.info
} else {
$b.f.info configure -text [::msgcat::mc $inf]
grid $b.f.info
}
update idletasks
set screenw [winfo screenwidth $w]
set screenh [winfo screenheight $w]
set reqw [winfo reqwidth $b]
set reqh [winfo reqheight $b]
# When adjusting for being on the screen boundary, check that we are
# near the "edge" already, as Tk handles multiple monitors oddly
if {$i eq "cursor"} {
set y [expr {[winfo pointery $w]+20}]
if {($y < $screenh) && ($y+$reqh) > $screenh} {
set y [expr {[winfo pointery $w]-$reqh-5}]
}
} elseif {$i ne ""} {
set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[$w yposition $i]+25}]
if {($y < $screenh) && ($y+$reqh) > $screenh} {
# show above if we would be offscreen
set y [expr {[winfo rooty $w]+[$w yposition $i]-$reqh-5}]
}
} else {
set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[winfo height $w]+5}]
if {($y < $screenh) && ($y+$reqh) > $screenh} {
# show above if we would be offscreen
set y [expr {[winfo rooty $w]-$reqh-5}]
}
}
if {$i eq "cursor"} {
set x [winfo pointerx $w]
} else {
set x [expr {[winfo rootx $w]+[winfo vrootx $w]+
([winfo width $w]-$reqw)/2}]
}
# only readjust when we would appear right on the screen edge
if {$x<0 && ($x+$reqw)>0} {
set x 0
} elseif {($x < $screenw) && ($x+$reqw) > $screenw} {
set x [expr {$screenw-$reqw}]
}
if {[tk windowingsystem] eq "aqua"} {
set focus [focus]
}
# avoid the blink issue with 1 to <1 alpha on Windows, watch half-fading
catch {wm attributes $b -alpha 0.99}
wm geometry $b +$x+$y
wm deiconify $b
raise $b
if {[tk windowingsystem] eq "aqua" && $focus ne ""} {
# Aqua's help window steals focus on display
after idle [list focus -force $focus]
}
}
proc ::tooltip::menuMotion {w} {
variable G
if {$G(enabled)} {
variable tooltip
# Menu events come from a funny path, map to the real path.
set m [string map {"#" "."} [winfo name $w]]
set cur [$w index active]
# The next two lines (all uses of LAST) are necessary until the
# <<MenuSelect>> event is properly coded for Unix/(Windows)?
if {$cur == $G(LAST)} return
set G(LAST) $cur
# a little inlining - this is :hide
after cancel $G(AFTERID)
catch {wm withdraw $G(TOPLEVEL)}
if {[info exists tooltip($m,$cur)] || \
(![catch {$w entrycget $cur -label} cur] && \
[info exists tooltip($m,$cur)])} {
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($m,$cur) cursor]]]
}
}
}
proc ::tooltip::hide {{fadeOk 0}} {
variable G
after cancel $G(AFTERID)
after cancel $G(FADEID)
if {$fadeOk && $G(fade)} {
fade $G(TOPLEVEL) $G(FADESTEP)
} else {
catch {wm withdraw $G(TOPLEVEL)}
}
}
proc ::tooltip::fade {w step} {
if {[catch {wm attributes $w -alpha} alpha] || $alpha <= 0.0} {
catch { wm withdraw $w }
catch { wm attributes $w -alpha 0.99 }
} else {
variable G
wm attributes $w -alpha [expr {$alpha-$step}]
set G(FADEID) [after 50 [namespace code [list fade $w $step]]]
}
}
proc ::tooltip::wname {{w {}}} {
variable G
if {[llength [info level 0]] > 1} {
# $w specified
if {$w ne $G(TOPLEVEL)} {
hide
destroy $G(TOPLEVEL)
set G(TOPLEVEL) $w
}
}
return $G(TOPLEVEL)
}
proc ::tooltip::listitemTip {w x y} {
variable tooltip
variable G
set G(LAST) -1
set item [$w index @$x,$y]
if {$G(enabled) && [info exists tooltip($w,$item)]} {
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($w,$item) cursor]]]
}
}
# Handle the lack of <Enter>/<Leave> between listbox items using <Motion>
proc ::tooltip::listitemMotion {w x y} {
variable tooltip
variable G
if {$G(enabled)} {
set item [$w index @$x,$y]
if {$item ne $G(LAST)} {
set G(LAST) $item
after cancel $G(AFTERID)
catch {wm withdraw $G(TOPLEVEL)}
if {[info exists tooltip($w,$item)]} {
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($w,$item) cursor]]]
}
}
}
}
# Initialize tooltip events for Listbox widgets
proc ::tooltip::enableListbox {w args} {
if {[string match *listitemTip* [bind $w <Enter>]]} { return }
bind $w <Enter> +[namespace code [list listitemTip %W %x %y]]
bind $w <Motion> +[namespace code [list listitemMotion %W %x %y]]
bind $w <Leave> +[namespace code [list hide 1]] ; # fade ok
bind $w <Any-KeyPress> +[namespace code hide]
bind $w <Any-Button> +[namespace code hide]
}
proc ::tooltip::itemTip {w args} {
variable tooltip
variable G
set G(LAST) -1
set item [$w find withtag current]
if {$G(enabled) && [info exists tooltip($w,$item)]} {
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($w,$item) cursor]]]
}
}
proc ::tooltip::enableCanvas {w args} {
if {[string match *itemTip* [$w bind all <Enter>]]} { return }
$w bind all <Enter> +[namespace code [list itemTip $w]]
$w bind all <Leave> +[namespace code [list hide 1]] ; # fade ok
$w bind all <Any-KeyPress> +[namespace code hide]
$w bind all <Any-Button> +[namespace code hide]
}
proc ::tooltip::tagTip {w tag} {
variable tooltip
variable G
set G(LAST) -1
if {$G(enabled) && [info exists tooltip($w,t_$tag)]} {
if {[info exists G(AFTERID)]} { after cancel $G(AFTERID) }
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($w,t_$tag) cursor]]]
}
}
proc ::tooltip::enableTag {w tag} {
if {[string match *tagTip* [$w tag bind $tag]]} { return }
$w tag bind $tag <Enter> +[namespace code [list tagTip $w $tag]]
$w tag bind $tag <Leave> +[namespace code [list hide 1]] ; # fade ok
$w tag bind $tag <Any-KeyPress> +[namespace code hide]
$w tag bind $tag <Any-Button> +[namespace code hide]
}
package provide tooltip 1.4.7
