Open Mash Cross Reference
mash/tcl/mb/tix.tcl

   # tix.tcl --
   #
   #       Popup tips for Tk
   
   # ---------------------------------------------------------------------------
   # This software is in the public domain, furnished "as is", without technical
   # support, and with no warranty, express or implied, as to its usefulness for
   # any purpose.
   #
  # tips.tcl
  # Popup tips for Tk
  # ---------------------------------------------------------------------------
  
  # -- module -----------------------------------------------------------------
  #
  # This package provides popup tips for widgets in Tcl/Tk.  Call "add_tip"
  # to add a tip to a widget, and "remove_tip" to remove it.
  #
  # ---------------------------------------------------------------------------
  
  package provide "tips" 1.0
  
  #
  # Programmatic defaults: feel free to adjust the first three.
  #
  array set tip_priv {
      window_delay             500
      y_offset                 5
      x_offset                 20
      currently_tipping        ""
      tips_enabled             1
      tips_initialized         0
  }
  
  # -- proc -------------------------------------------------------------------
  # add_tip
  #
  # Add a tip message to the given widget.  When the pointer enters the
  # widget, it'll wait a bit, then if it's still there, it'll map the
  # tip window.  As soon as the pointer leaves, then it unmaps it.
  # ---------------------------------------------------------------------------
  proc add_tip {window msg} {
      global tip_priv
  
      if {! $tip_priv(tips_initialized)} {tip_init_tips}
  
      # Save the message text for later use.
      set tip_priv($window) $msg
  
      # Add the tip bindings to the window ... now, it might already have
      # them if we got called to change the text, so check first.
      set tags [bindtags $window]
      if {[lsearch -exact $tags TipBindings] == -1} {
          # They're not in there, add 'em.
          bindtags $window [concat TipBindings [bindtags $window]]
      }
  }
  
  # -- proc -------------------------------------------------------------------
  # remove_tip
  #
  # Remove the popup tip for this window.
  # ---------------------------------------------------------------------------
  proc remove_tip {window} {
      global tip_priv
  
      # Do we have saved text for this window?  If so, then we have to get rid of it
      # and the window's class binding, too.
      if [info exists tip_priv($window)] {
          # Okay, nuke the text.
          unset tip_priv($window)
  
          # Now, get the tags and see if the TipBindings is among them.
          set tags [bindtags $window]
          if {[set index [lsearch -exact $tags TipBindings]] >= 0} {
              # Yep, it's there.  Set the new bindings without TipBindings present.
              bindtags $window [lreplace $tags $index $index]
          }
  
          # Also, if the tip window is visible for this widget, nuke it.
          if {$tip_priv(currently_tipping) == $window} {
              destroy .tip
              set tip_priv(currently_tipping) ""
          }
      } else {
          # It's not set?  Well, I never.
          error "No popup tip set for $window"
      }
  }
  
  # -- proc -------------------------------------------------------------------
  # enable_tips
  #
  # With boolean true, enable all popup tips.  False, disable all of them.
  # ---------------------------------------------------------------------------
  proc enable_tips {bool} {
      global tip_priv
  
      set tip_priv(tips_enabled) $bool
     if {! $bool && $tip_priv(currently_tipping) != ""} {
         destroy $tip_priv(currently_tipping)
         set tip_priv(currently_tipping) ""
     }
 }
 
 # -- proc -------------------------------------------------------------------
 # tip_make_window
 #
 # Make and map the tip window for the given widget.
 # ---------------------------------------------------------------------------
 proc tip_make_window {window} {
     global tip_priv
 
     # Note that we're mapping the tip window.
     set tip_priv(currently_tipping) $window
 
     # Get rid of it if it already exists
     catch {destroy .tip}
 
     # Figure out the X and Y coord of the tip window.  It should be below the widget it's tipping,
     # and slightly to the right of its left edge, too.
     set y [expr [winfo rooty $window] + [winfo height $window] + $tip_priv(y_offset)]
     set x [expr [winfo rootx $window] + $tip_priv(x_offset)]
 
     # Create it at the correct coords, and prevent the window manager from slapping a border around it.
     toplevel .tip -class Tip
     wm overrideredirect .tip yes
     wm geometry .tip +$x+$y
     # Insert the message and we're done.
     pack [message .tip.message -text $tip_priv($window) -bg beige]
 }
 
 # -- proc -------------------------------------------------------------------
 # tip_cancel_tip
 #
 # Cancel any currently displayed tip by unmapping the window (if it's mapped)
 # and by canceling the timer to display a window.
 # ---------------------------------------------------------------------------
 proc tip_cancel_tip {} {
     global tip_priv
 
     if {! $tip_priv(tips_enabled)} return
 
     if {$tip_priv(currently_tipping) != ""} {
         catch {destroy .tip}
         set tip_priv(currently_tipping) ""
     }
     catch {after cancel $tip_priv(after_id)}
 }
 
 # -- proc -------------------------------------------------------------------
 # tip_init_tips
 #
 # Initialize the tips.  Currently, this just means adding X resources
 # and setting up bindings.  Override these in your own X resources, if
 # you must.  (Note that if you use Vue, you likely have things like
 # "*background", which will override these settings no matter what.
 # You may want to add these settings in that case.)
 # ---------------------------------------------------------------------------
 proc tip_init_tips {} {
     global tip_priv
 
     # X defaults for the popup.
     option add "*tip.message.background"  "LemonChiffon"                widgetDefault
     option add "*tip.message.foreground"  "Black"                       widgetDefault
     option add "*tip.message.relief"      "raised"                      widgetDefault
     option add "*tip.message.borderWidth" "2"                           widgetDefault
     option add "*tip.message.justify"     "left"                        widgetDefault
     option add "*tip.message.aspect"      "350"                         widgetDefault
     option add "*tip.message.font"        "-*-helvetica-medium-r-normal-*-*-120-*-*-*-*-*-*" widgetDefault
 
     # Bindings for the TipBindings tag.
     bind TipBindings <Enter> {
         global tip_priv
 
         if {! $tip_priv(tips_enabled)} continue
 
         set tip_priv(currently_tipping) ""
         set tip_priv(after_id) [after $tip_priv(window_delay) tip_make_window %W]
     }
     bind TipBindings <Leave> {
         tip_cancel_tip
     }
     bind TipBindings <Button-1> {
         tip_cancel_tip
     }
     bind TipBindings <space> {
         tip_cancel_tip
     }
 
     set tip_priv(tips_initialized) 1
 }