2 # Package tooltip - creates floating tips for widget
4 # 1. Static text set upon tip creation
5 # 2. Contents of specified variable
6 # 3. Result of command execution
8 # Tooltips are really top-level windows with class Tooltip named
12 # Uses resources *Tooltip*Font
15 # *Tooltip.Delay (popup delay, ms)
21 option set *Tooltip*Font {Fixed 10} widgetDefault
22 option set *Tooltip*Background yellow widgetDefault
23 option set *Tooltip*Foreground black widgetDefault
24 option set *Tooltip.BorderWidth 1 widgetDefault
25 option set *Tooltip.Delay 2000 widgetDefault
29 # tooltip widget ?-text "Text" | -variable varname | -command command?
33 namespace eval tooltip {
34 proc tooltip {widget args} {
36 if [winfo exist $widget.tooltip] {
37 clearTipCommand $widget
38 setupTipLabel $widget $args
40 toplevel $widget.tooltip -class Tooltip
41 label $widget.tooltip.l
42 pack $widget.tooltip.l
43 wm withdraw $widget.tooltip
44 wm overrideredirect $widget.tooltip
46 setupTipLabel $widget $args
49 proc clearTipCommand widget {
51 if [info exists tipcommand($widget)] {
52 unset tipcommand($widget.tooltip)
57 proc setupBindings {widget} {
58 bind $widget <Enter> {+::tooltip::start %W}
59 bind $widget <Leave> {+::tooltip::cancel %W}
60 bind $widget <Motion> {+::tooltip::reset %W}
61 bind $widget <Destroy> {+::tooltip::cancel %W;
62 ::tooltip::clearTipCommand %W}
67 set afterId($widget) [after [option get $widget.tooltip delay Delay] [list ::tooltip::show $widget]]
70 proc cancel {widget} {
72 if {[info exists afterId($widget)]} {
73 after cancel $afterId($widget)
74 unset afterId($widget)
76 if {[wm state $widget.tooltip]=="normal"} {
77 wm withdraw $widget.tooltip
83 if [info exists tipcommand($widget)] {
84 $widget.tooltip.l configure -text [uplevel $tipcommand($widget)]
86 wm geometry $widget.tooltip +[expr [winfo pointerx $widget]+2]+[expr [winfo pointery $widget]+2]
87 wm deiconify $widget.tooltip
95 proc setupTipLabel {widget arglist} {
97 foreach {type value} $arglist break
98 switch -glob -- $type {
99 -text {$widget.tooltip.l configure -text $value}
100 -var* {$widget.tooltip.l configure -textvar $value}
101 -comm* {set tipcommand($widget) $value}
103 return -code error "Invalid option should be one of -text -variable -command"
107 namespace export tooltip
109 namespace import tooltip::*
111 package provide tooltip 0.1