balloon.tcl

This Source-Navigator, an IDE for C/C++/Fortran/Java/Tcl/PHP/Python and a host of other languages.

# balloon.tcl - Balloon help.
# Copyright (C) 1997, 1998, 2000 Cygnus Solutions.
# Written by Tom Tromey <[e-mail]>.

# KNOWN BUGS:
# * On Windows, various delays should be determined from system;
#   presently they are hard-coded.
# * Likewise, balloon positioning on Windows is a hack.

itcl_class Balloon {
  # Name of associated global variable which should be set whenever
  # the help is shown.
  public variable {}

  # Name of associated toplevel.  Private variable.
  protected _top {}

  # This is non-empty if there is an after script pending.  Private
  # method.
  protected _after_id {}

  # This is an array mapping window name to help text.
  protected _help_text

  # This is an array mapping window name to notification proc.
  protected _notifiers

  # This is set to the name of the parent widget whenever the mouse is
  # in a widget with balloon help.
  protected _active {}

  # This is true when we're already calling a notification proc.
  # Private variable.
  protected _in_notifier 0

  # This holds the parent of the most recently entered widget.  It is
  # used to determine when the user is moving through a toolbar.
  # Private variable.
  protected _recent_parent {}

  constructor {top} {
    global tcl_platform

    set _top $top
    set class [$this info class]

    # The standard widget-making trick.
    set hull [namespace tail $this]
    set old_name $this
    ::rename $this $this-tmp-
    ::toplevel $hull -class $class -borderwidth 1 -background black
    ::rename $hull $old_name-win-
    ::rename $this $old_name

    # By default we are invisible.  When we are visible, we are
    # borderless.
    wm withdraw  [namespace tail $this]
    wm overrideredirect  [namespace tail $this] 1

    # Put some bindings on the toplevel.  We don't use
    # bind_for_toplevel_only because *do* want these bindings to be
    # run when the event happens on some child.
    bind $_top <Enter> [list $this _enter %W]
    bind $_top <Leave> [list $this _leave]
    # Only run this one if we aren't already destroyed.
    bind $_top <Destroy> [format {
      if {[info commands %s] != ""} then {
	%s _subdestroy %%W
      }
    } $this $this]
    bind $_top <Unmap> [list $this _unmap %W]
    # Add more here as required.
    bind $_top <1> [format {
      %s _cancel
      %s _unshowballoon
    } $this $this]
    bind $_top <3> [format {
      %s _cancel
      %s _unshowballoon
    } $this $this]

    if {$tcl_platform(platform) == "windows"} then {
      set bg SystemInfoBackground
      set fg SystemInfoText
    } else {
      # This color is called `LemonChiffon' by my X installation.
      set bg \#ffffffffcccc
      set fg black
    }

    # Where we display stuff.
    label [namespace tail $this].label -background $bg -foreground $fg -font global/status \
      -anchor w -justify left
    pack [namespace tail $this].label -expand 1 -fill both

    # Clean up when the label is destroyed.  This has the hidden
    # assumption that the balloon widget is a child of the toplevel to
    # which it is connected.
    bind [namespace tail $this].label <Destroy> [list $this delete]
  }

  destructor {
    catch {_cancel}
    catch {after cancel [list $this _unshowballoon]}
    catch {destroy $this}
  }

  method configure {config} {}

  # Register a notifier for a window.
  method notify {command window {tag {}}} {
    if {$tag == ""} then {
      set item $window
    } else {
      set item $window,$tag
    }

    if {$command == ""} then {
      unset _notifiers($item)
    } else {
      set _notifiers($item) $command
    }
  }

  # Register help for a window.
  method register {window text {tag {}}} {
    if {$tag == ""} then {
      set item $window
    } else {
      # Switching on the window class is bad.  Do something better.
      set class [winfo class $window]

      # Switching on window class is bad.  Do something better.
      switch -- $class {
	Menu {
	  # Menus require bindings that other items do not require.
	  # So here we make sure the menu has the binding.  We could
	  # speed this up by keeping a special entry in the _help_text
	  # array if we wanted.  Note that we pass in the name of the
	  # window as we know it.  That lets us work even when we're
	  # actually getting events for a clone window.  This is less
	  # than ideal, because it means we have to hijack the
	  # MenuSelect binding, but we live with it.  (The other
	  # choice is to make a new bindtag per menu -- yuck.)
	  # This is relatively nasty: we have to encode the window
	  # name as passed to the _motion method; otherwise the
	  # cloning munges it.  Sigh.
	  regsub -all -- \\. $window ! munge
	  bind $window <<MenuSelect>> [list $this _motion %W $munge]
	}

	Canvas {
	  # If we need to add a binding for this tag, do so.
	  if {! [info exists _help_text($window,$tag)]} then {
	    $window bind $tag <Enter> +[list $this _enter $window $tag]
	    $window bind $tag <Leave> +[list $this _leave]
	    $window bind $tag <1> +[format {
	      %s _cancel
	      %s _unshowballoon
	    } $this $this]
	  }
	}

	Text {
	  # If we need to add a binding for this tag, do so.
	  if {! [info exists _help_text($window,$tag)]} then {
	    $window tag bind $tag <Enter> +[list $this _enter $window $tag]
	    $window tag bind $tag <Leave> +[list $this _leave]
	    $window tag bind $tag <1> +[format {
	      %s _cancel
	      %s _unshowballoon
	    } $this $this]
	  }
	}
      }

      set item $window,$tag
    }

    set _help_text($item) $text
    if {$_active == $item} then {
      _set_variable $item
      # If the label is already showing, then we re-show it.  Why not
      # just set the -text on the label?  Because if the label changes
      # size it might be offscreen, and we need to handle that.
      if {[wm state [namespace tail $this]] == "normal"} then {
	showballoon $window $tag
      }
    }
  }

  # Cancel any pending after handler.  Private method.
  method _cancel {} {
    if {$_after_id != ""} then {
      after cancel $_after_id
      set _after_id {}
    }
  }

  # This is run when the toplevel, or any child, is entered.  Private
  # method.
  method _enter {W {tag {}}} {
    _cancel

    # Don't bother for menus, since we know we use a different
    # mechanism for them.
    if {[winfo class $W] == "Menu"} then {
      return
    }

    # If we just moved into the parent of the last child, then do
    # nothing.  We want to keep the parent the same so the right thing
    # can happen if we move into a child of this same parent.
    set delay 1000
    if {$W != $_recent_parent} then {
      if {[winfo parent $W] == $_recent_parent} then {
	# As soon as possible.
	set delay idle
      } else {
	set _recent_parent ""
      }
    }

    if {$tag == ""} then {
      set index $W
    } else {
      set index $W,$tag
    }
    set _active $index
    if {[info exists _help_text($index)]} then {
      # There is some help text.  So arrange to display it when the
      # time is up.  We arbitrarily set this to 1 second.
      set _after_id [after $delay [list $this showballoon $W $tag]]

      # Set variable here; that way simply entering a window will
      # cause the text to appear.
      _set_variable $index
    }
  }

  # This is run when the toplevel, or any child, is left.  Private
  # method.
  method _leave {} {
    _cancel
    _unshowballoon
    _set_variable {}
    set _active {}
  }

  # This is run to undisplay the balloon.  Note that it does not
  # change the text stored in the variable.  That is handled
  # elsewhere.  Private method.
  method _unshowballoon {} {
    wm withdraw  [namespace tail $this]
  }

  # Set the variable, if it exists.  Private method.
  method _set_variable {index} {
    # Run the notifier.
    if {$index == ""} then {
      set value ""
    } elseif {[info exists _notifiers($index)] && ! $_in_notifier} then {
      if {$variable != ""} {
	upvar $variable var
	set var $_help_text($index)
      }
      set _in_notifier 1
      uplevel \#0 $_notifiers($index)
      set _in_notifier 0
      # Get value afterwards to give notifier a chance to change it.
      if {$variable != ""} {
	upvar $variable var