tooltip.tcl

   1 #
   2 # Package tooltip - creates floating tips for widget
   3 # tips can display
   4 # 1. Static text set upon tip creation
   5 # 2. Contents of specified variable
   6 # 3. Result of command execution
   7 #
   8 # Tooltips are really top-level windows with class Tooltip named
   9 # $widget.tooltip
  10 #
  11
  12 # Uses resources *Tooltip*Font
  13 # *Tooltip*Foreground
  14 # *Tooltip*Background
  15 # *Tooltip.Delay (popup delay, ms)
  16
  17 # Default options
  18
  19 package require Tk
  20
  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
  26
  27 #
  28 # Syntax:
  29 #   tooltip widget ?-text "Text" | -variable varname | -command command?
  30 #
  31 #
  32
  33 namespace eval tooltip {
  34         proc tooltip {widget args} {
  35                 variable tipcommand
  36                 if [winfo exist $widget.tooltip] {
  37                         clearTipCommand $widget
  38                         setupTipLabel $widget $args
  39                 } else {
  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
  45                         setupBindings $widget
  46                         setupTipLabel $widget $args
  47                 }
  48         }
  49         proc clearTipCommand widget {
  50                 variable tipcommand
  51                 if [info exists tipcommand($widget)] {
  52                         unset tipcommand($widget.tooltip)
  53                 }
  54         }
  55
  56
  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}
  63         }
  64
  65         proc start {widget} {
  66                 variable afterId
  67                 set afterId($widget) [after [option get $widget.tooltip delay Delay] [list ::tooltip::show $widget]]
  68         }
  69
  70         proc cancel {widget} {
  71                 variable afterId
  72                 if {[info exists afterId($widget)]} {
  73                         after cancel $afterId($widget)
  74                         unset afterId($widget)
  75                 }
  76                 if {[wm state $widget.tooltip]=="normal"} {
  77                         wm withdraw $widget.tooltip
  78                 }
  79         }
  80
  81         proc show {widget} {
  82                 variable tipcommand
  83                 if [info exists tipcommand($widget)] {
  84                         $widget.tooltip.l configure -text [uplevel $tipcommand($widget)]
  85                 }
  86                 wm geometry $widget.tooltip +[expr [winfo pointerx $widget]+2]+[expr [winfo pointery $widget]+2]
  87                 wm deiconify $widget.tooltip
  88                 raise $widget.tooltip
  89         }
  90
  91         proc reset {widget} {
  92                 cancel $widget
  93                 start $widget
  94         }
  95         proc setupTipLabel {widget arglist} {
  96                 variable tipcommand
  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}
 102                         default {
 103                                 return -code error "Invalid option should be one of -text -variable -command"
 104                         }
 105                 }
 106         }
 107         namespace export tooltip
 108 }
 109         namespace import tooltip::*
 110
 111 package provide tooltip 0.1