balloon.tcl

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

	set _help_text($index) $var
      } 
      set value $_help_text($index)
    } else {
      set value $_help_text($index)
    }

    if {$variable != ""} then {
      upvar $variable var
      set var $value
    }
  }

  # This is run to show the balloon.  Private method.
  method showballoon {W tag {keep 0}} {
    global tcl_platform

    if {$tag == ""} then {
      # An ordinary window.  Position below the window, and right of
      # center.
      set _active $W
      set left [expr {[winfo rootx $W] + round ([winfo width $W] * .75)}]
      set ypos [expr {[winfo rooty $W] + [winfo height $W]}]
      set alt_ypos [winfo rooty $W]

      # Balloon shown, so set parent info.
      set _recent_parent [winfo parent $W]
    } else {
      set _active $W,$tag
      # Switching on class name is bad.  Do something better.  Can't
      # just use the widget's bbox method, because the results differ
      # for Text and Canvas widgets.  Bummer.
      switch -- [winfo class $W] {
	Menu {
	  # Recognize but do nothing.
	}

	Text {
	  lassign [$W bbox $tag.first] x y width height
	  set left [expr {[winfo rootx $W] + $x + round ($width * .75)}]
	  set ypos [expr {[winfo rooty $W] + $y + $height}]
	  set alt_ypos [expr {[winfo rooty $W] - $y}]
	}

	Canvas {
	  lassign [$W bbox $tag] x1 y1 x2 y2
	  # Must subtract out coordinates of top-left corner of canvas
	  # window; otherwise this will get the wrong position when
	  # the canvas has been scrolled.
	  set tlx [$W canvasx 0]
	  set tly [$W canvasy 0]
	  # Must round results because canvas coordinates are floats.
	  set left [expr {round ([winfo rootx $W] + $x1 - $tlx
				 + ($x2 - $x1) * .75)}]
	  set ypos [expr {round ([winfo rooty $W] + $y2 - $tly)}]
	  set alt_ypos [expr {round ([winfo rooty $W] + $y1 - $tly)}]
	}

	default {
	  error "unrecognized window class for window \"$W\""
	}
      }
    }

    set help $_help_text($_active)

    # On Windows, the popup location is always determined by the
    # cursor.  Actually, the rule seems to be somewhat more complex.
    # Unfortunately it doesn't seem to be written down anywhere.
    # Experiments show that the location is determined by the cursor
    # if the text is wider than the widget; and otherwise it is
    # centered under the widget.  FIXME: we don't deal with those
    # cases.
    if {$tcl_platform(platform) == "windows"} then {
      # FIXME: for now this is turned off.  It isn't enough to get the
      # cursor size; we actually have to find the bottommost "on"
      # pixel in the cursor and use that for the height.  I don't know
      # how to do that.
      # lassign [ide_cursor size] dummy height
      # lassign [ide_cursor position] left ypos
      # incr ypos $height
    }

    if {[info exists left] && $help != ""} then {
      [namespace tail $this].label configure -text $help
      set lw [winfo reqwidth [namespace tail $this].label]
      set sw [winfo screenwidth [namespace tail $this]]
      set bw [$this-win- cget -borderwidth]
      if {$left + $lw + 2 * $bw >= $sw} then {
	set left [expr {$sw - 2 * $bw - $lw}]
      }

      set lh [winfo reqheight [namespace tail $this].label]
      if {$ypos + $lh >= [winfo screenheight [namespace tail $this]]} then {
	set ypos [expr {$alt_ypos - $lh}]
      }

      wm positionfrom  [namespace tail $this] user
      wm geometry  [namespace tail $this] +${left}+${ypos}
      update
      wm deiconify  [namespace tail $this]
      raise  [namespace tail $this]

      if {!$keep} {
	# After 6 seconds, close the window.  The timer is reset every
	# time the window is shown.
	after cancel [list $this _unshowballoon]
	after 6000 [list $this _unshowballoon]
      }
    }
  }

  # This is run when a window or tag is destroyed.  Private method.
  method _subdestroy {W {tag {}}} {
    if {$tag == ""} then {
      # A window.  Remove the window and any associated tags.  Note
      # that this is called for all Destroy events on descendents,
      # even for windows which were never registered.  Hence the use
      # of catch.
      catch {unset _help_text($W)}
      foreach thing [array names _help_text($W,*)] {
	unset _help_text($thing)
      }
    } else {
      # Just a tag.  This one can't be called by mistake, so this
      # shouldn't need to be caught.
      unset _help_text($W,$tag)
    }
  }

  # This is run in response to a MenuSelect event on a menu.
  method _motion {window name} {
    # Decode window name.
    regsub -all -- ! $name . name

    if {$variable == ""} then {
      # There's no point to doing anything.
      return
    }

    set n [$window index active]
    if {$n == "none"} then {
      set index ""
      set _active {}
    } elseif {[info exists _help_text($name,$n)]} then {
      # Tag specified by index number.
      set index $name,$n
      set _active $name,$n
    } elseif {! [catch {$window entrycget $n -label} label]
	      && [info exists _help_text($name,$label)]} then {
      # Tag specified by index name.
      set index $name,$label
      set _active $name,$label
    } else {
      # No help for this item.
      set index ""
      set _active {}
    }

    _set_variable $index
  }

  # This is run when some widget unmaps.  If the widget is the current
  # widget, then unmap the balloon help.  Private method.
  method _unmap w {
    if {$w == $_active} then {
      _cancel
      _unshowballoon
      _set_variable {}
      set _active {}
    }
  }
}


################################################################

# Find (and possibly create) balloon widget associated with window.
proc BALLOON_find_balloon {window} {
  # Find our associated toplevel.  If it is a menu, then keep going.
  set top [winfo toplevel $window]
  while {[winfo class $top] == "Menu"} {
    set top [winfo toplevel [winfo parent $top]]
  }

  if {$top == "."} {
    set bname .__balloon
  } else {
    set bname $top.__balloon
  }
  
  # If the balloon help for this toplevel doesn't exist, then create
  # it.  Yes, this relies on a magic name for the balloon help widget.
  if {! [winfo exists $bname]} then {
    Balloon $bname $top
  }  
  return $bname
}

# This implements "balloon register".
proc BALLOON_command_register {window text {tag {}}} {
  set b [BALLOON_find_balloon $window]
  $b register $window $text $tag
}

# This implements "balloon notify".
proc BALLOON_command_notify {command window {tag {}}} {
  set b [BALLOON_find_balloon $window]
  $b notify $command $window $tag
}

# This implements "balloon show".
proc BALLOON_command_show {window {tag {}} {keep 0}} {
  set b [BALLOON_find_balloon $window]
  $b showballoon $window $tag $keep
}

proc BALLOON_command_withdraw {window} {
  set b [BALLOON_find_balloon $window]
  $b _unmap $window
}
    
# This implements "balloon variable".
proc BALLOON_command_variable {window args} {
  if {[llength $args] == 0} then {
    # Fetch.
    set b [BALLOON_find_balloon $window]
    return [$b cget -variable]
  } else {
    # FIXME: no arg checking here.
    # Set.
    set b [BALLOON_find_balloon $window]
    $b configure -variable [lindex $args 0]
  }
}

# The primary interface to balloon help.
# Usage:
#  balloon notify COMMAND WINDOW ?TAG?
#    Run COMMAND just before the help text for WINDOW (and TAG, if
#    given) is displayed.  If COMMAND is the empty string, then
#    notification is disabled for this window.
#  balloon register WINDOW TEXT ?TAG?
#    Associate TEXT as the balloon help for WINDOW.
#    If TAG is given, the use the appropriate tag for association.
#    For menu widgets, TAG is a menu index.
#    For canvas widgets, TAG is a tagOrId.
#    For text widgets, TAG is a text index.  If you want to use
#      the text tag FOO, use `FOO.last'.
#  balloon show WINDOW ?TAG?
#    Immediately pop up the balloon for the given window and tag.
#    This should be used sparingly.  For instance, you might need to
#    use it if the tag you're interested in does not track the mouse,
#    but instead is added just before show-time.
#  balloon variable WINDOW ?NAME?
#    If NAME specified, set balloon help variable associated
#    with window.  This variable is set to the text whenever the
#    balloon help is on.  If NAME is specified but empty,
#    no variable is set.  If NAME not specified, then the
#    current variable name is returned.
#  balloon withdraw WINDOW
#    Withdraw the balloon window associated with WINDOW.  This should
#    be used sparingly.
proc balloon {key args} {
  if {[info commands BALLOON_command_$key] == "" } then {
    error "unrecognized key \"$key\""
  }

  eval BALLOON_command_$key $args
}