URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [libgui/] [library/] [balloon.tcl] - Blame information for rev 1765

Details | Compare with Previous | View Log


# balloon.tcl - Balloon help.
# Copyright (C) 1997, 1998, 2000 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.
 
# 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 {
      set _in_notifier 1
      uplevel \#0 $_notifiers($index)
      set _in_notifier 0
      # Get value afterwards to give notifier a chance to change it.
      set value $_help_text($index)
    } else {
      set value $_help_text($index)
    }
 
    if {$variable != ""} then {
      # itcl 1.5 forces us to do this in a strange way.
      ::uplevel \#0 [list set $variable $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 help $_help_text($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
      set help $_help_text($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\""
        }
      }
    }
 
    # 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 [lindex $args 0]]
    return [lindex [$b configure -variable] 4]
  } 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
}

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [libgui/] [library/] [balloon.tcl] - Blame information for rev 1765

Line No.	Rev	Author	Line
1	578	markom	`# balloon.tcl - Balloon help.`
2			`# Copyright (C) 1997, 1998, 2000 Cygnus Solutions.`
3			`# Written by Tom Tromey <tromey@cygnus.com>.`
4
5			`# KNOWN BUGS:`
6			`# * On Windows, various delays should be determined from system;`
7			`# presently they are hard-coded.`
8			`# * Likewise, balloon positioning on Windows is a hack.`
9
10			`itcl_class Balloon {`
11			`# Name of associated global variable which should be set whenever`
12			`# the help is shown.`
13			`public variable {}`
14
15			`# Name of associated toplevel. Private variable.`
16			`protected _top {}`
17
18			`# This is non-empty if there is an after script pending. Private`
19			`# method.`
20			`protected _after_id {}`
21
22			`# This is an array mapping window name to help text.`
23			`protected _help_text`
24
25			`# This is an array mapping window name to notification proc.`
26			`protected _notifiers`
27
28			`# This is set to the name of the parent widget whenever the mouse is`
29			`# in a widget with balloon help.`
30			`protected _active {}`
31
32			`# This is true when we're already calling a notification proc.`
33			`# Private variable.`
34			`protected _in_notifier 0`
35
36			`# This holds the parent of the most recently entered widget. It is`
37			`# used to determine when the user is moving through a toolbar.`
38			`# Private variable.`
39			`protected _recent_parent {}`
40
41			`constructor {top} {`
42			`global tcl_platform`
43
44			`set _top $top`
45			`set class [$this info class]`
46
47			`# The standard widget-making trick.`
48			`set hull [namespace tail $this]`
49			`set old_name $this`
50			`::rename $this $this-tmp-`
51			`::toplevel $hull -class $class -borderwidth 1 -background black`
52			`::rename $hull $old_name-win-`
53			`::rename $this $old_name`
54
55			`# By default we are invisible. When we are visible, we are`
56			`# borderless.`
57			`wm withdraw [namespace tail $this]`
58			`wm overrideredirect [namespace tail $this] 1`
59
60			`# Put some bindings on the toplevel. We don't use`
61			`# bind_for_toplevel_only because do want these bindings to be`
62			`# run when the event happens on some child.`
63			`bind $_top <Enter> [list $this _enter %W]`
64			`bind $_top <Leave> [list $this _leave]`
65			`# Only run this one if we aren't already destroyed.`
66			`bind $_top <Destroy> [format {`
67			`if {[info commands %s] != ""} then {`
68			`%s _subdestroy %%W`
69			`}`
70			`} $this $this]`
71			`bind $_top <Unmap> [list $this _unmap %W]`
72			`# Add more here as required.`
73			`bind $_top <1> [format {`
74			`%s _cancel`
75			`%s _unshowballoon`
76			`} $this $this]`
77			`bind $_top <3> [format {`
78			`%s _cancel`
79			`%s _unshowballoon`
80			`} $this $this]`
81
82			`if {$tcl_platform(platform) == "windows"} then {`
83			`set bg SystemInfoBackground`
84			`set fg SystemInfoText`
85			`} else {`
86			# This color is called `LemonChiffon' by my X installation.
87			`set bg \#ffffffffcccc`
88			`set fg black`
89			`}`
90
91			`# Where we display stuff.`
92			`label [namespace tail $this].label -background $bg -foreground $fg -font global/status \`
93			`-anchor w -justify left`
94			`pack [namespace tail $this].label -expand 1 -fill both`
95
96			`# Clean up when the label is destroyed. This has the hidden`
97			`# assumption that the balloon widget is a child of the toplevel to`
98			`# which it is connected.`
99			`bind [namespace tail $this].label <Destroy> [list $this delete]`
100			`}`
101
102			`destructor {`
103			`catch {_cancel}`
104			`catch {after cancel [list $this _unshowballoon]}`
105			`catch {destroy $this}`
106			`}`
107
108			`method configure {config} {}`
109
110			`# Register a notifier for a window.`
111			`method notify {command window {tag {}}} {`
112			`if {$tag == ""} then {`
113			`set item $window`
114			`} else {`
115			`set item $window,$tag`
116			`}`
117
118			`if {$command == ""} then {`
119			`unset _notifiers($item)`
120			`} else {`
121			`set _notifiers($item) $command`
122			`}`
123			`}`
124
125			`# Register help for a window.`
126			`method register {window text {tag {}}} {`
127			`if {$tag == ""} then {`
128			`set item $window`
129			`} else {`
130			`# Switching on the window class is bad. Do something better.`
131			`set class [winfo class $window]`
132
133			`# Switching on window class is bad. Do something better.`
134			`switch -- $class {`
135			`Menu {`
136			`# Menus require bindings that other items do not require.`
137			`# So here we make sure the menu has the binding. We could`
138			`# speed this up by keeping a special entry in the _help_text`
139			`# array if we wanted. Note that we pass in the name of the`
140			`# window as we know it. That lets us work even when we're`
141			`# actually getting events for a clone window. This is less`
142			`# than ideal, because it means we have to hijack the`
143			`# MenuSelect binding, but we live with it. (The other`
144			`# choice is to make a new bindtag per menu -- yuck.)`
145			`# This is relatively nasty: we have to encode the window`
146			`# name as passed to the _motion method; otherwise the`
147			`# cloning munges it. Sigh.`
148			`regsub -all -- \\. $window ! munge`
149			`bind $window <<MenuSelect>> [list $this _motion %W $munge]`
150			`}`
151
152			`Canvas {`
153			`# If we need to add a binding for this tag, do so.`
154			`if {! [info exists _help_text($window,$tag)]} then {`
155			`$window bind $tag <Enter> +[list $this _enter $window $tag]`
156			`$window bind $tag <Leave> +[list $this _leave]`
157			`$window bind $tag <1> +[format {`
158			`%s _cancel`
159			`%s _unshowballoon`
160			`} $this $this]`
161			`}`
162			`}`
163
164			`Text {`
165			`# If we need to add a binding for this tag, do so.`
166			`if {! [info exists _help_text($window,$tag)]} then {`
167			`$window tag bind $tag <Enter> +[list $this _enter $window $tag]`
168			`$window tag bind $tag <Leave> +[list $this _leave]`
169			`$window tag bind $tag <1> +[format {`
170			`%s _cancel`
171			`%s _unshowballoon`
172			`} $this $this]`
173			`}`
174			`}`
175			`}`
176
177			`set item $window,$tag`
178			`}`
179
180			`set _help_text($item) $text`
181			`if {$_active == $item} then {`
182			`_set_variable $item`
183			`# If the label is already showing, then we re-show it. Why not`
184			`# just set the -text on the label? Because if the label changes`
185			`# size it might be offscreen, and we need to handle that.`
186			`if {[wm state [namespace tail $this]] == "normal"} then {`
187			`showballoon $window $tag`
188			`}`
189			`}`
190			`}`
191
192			`# Cancel any pending after handler. Private method.`
193			`method _cancel {} {`
194			`if {$_after_id != ""} then {`
195			`after cancel $_after_id`
196			`set _after_id {}`
197			`}`
198			`}`
199
200			`# This is run when the toplevel, or any child, is entered. Private`
201			`# method.`
202			`method _enter {W {tag {}}} {`
203			`_cancel`
204
205			`# Don't bother for menus, since we know we use a different`
206			`# mechanism for them.`
207			`if {[winfo class $W] == "Menu"} then {`
208			`return`
209			`}`
210
211			`# If we just moved into the parent of the last child, then do`
212			`# nothing. We want to keep the parent the same so the right thing`
213			`# can happen if we move into a child of this same parent.`
214			`set delay 1000`
215			`if {$W != $_recent_parent} then {`
216			`if {[winfo parent $W] == $_recent_parent} then {`
217			`# As soon as possible.`
218			`set delay idle`
219			`} else {`
220			`set _recent_parent ""`
221			`}`
222			`}`
223
224			`if {$tag == ""} then {`
225			`set index $W`
226			`} else {`
227			`set index $W,$tag`
228			`}`
229			`set _active $index`
230			`if {[info exists _help_text($index)]} then {`
231			`# There is some help text. So arrange to display it when the`
232			`# time is up. We arbitrarily set this to 1 second.`
233			`set _after_id [after $delay [list $this showballoon $W $tag]]`
234
235			`# Set variable here; that way simply entering a window will`
236			`# cause the text to appear.`
237			`_set_variable $index`
238			`}`
239			`}`
240
241			`# This is run when the toplevel, or any child, is left. Private`
242			`# method.`
243			`method _leave {} {`
244			`_cancel`
245			`_unshowballoon`
246			`_set_variable {}`
247			`set _active {}`
248			`}`
249
250			`# This is run to undisplay the balloon. Note that it does not`
251			`# change the text stored in the variable. That is handled`
252			`# elsewhere. Private method.`
253			`method _unshowballoon {} {`
254			`wm withdraw [namespace tail $this]`
255			`}`
256
257			`# Set the variable, if it exists. Private method.`
258			`method _set_variable {index} {`
259			`# Run the notifier.`
260			`if {$index == ""} then {`
261			`set value ""`
262			`} elseif {[info exists _notifiers($index)] && ! $_in_notifier} then {`
263			`set _in_notifier 1`
264			`uplevel \#0 $_notifiers($index)`
265			`set _in_notifier 0`
266			`# Get value afterwards to give notifier a chance to change it.`
267			`set value $_help_text($index)`
268			`} else {`
269			`set value $_help_text($index)`
270			`}`
271
272			`if {$variable != ""} then {`
273			`# itcl 1.5 forces us to do this in a strange way.`
274			`::uplevel \#0 [list set $variable $value]`
275			`}`
276			`}`
277
278			`# This is run to show the balloon. Private method.`
279			`method showballoon {W tag {keep 0}} {`
280			`global tcl_platform`
281
282			`if {$tag == ""} then {`
283			`# An ordinary window. Position below the window, and right of`
284			`# center.`
285			`set _active $W`
286			`set help $_help_text($W)`
287			`set left [expr {[winfo rootx $W] + round ([winfo width $W] * .75)}]`
288			`set ypos [expr {[winfo rooty $W] + [winfo height $W]}]`
289			`set alt_ypos [winfo rooty $W]`
290
291			`# Balloon shown, so set parent info.`
292			`set _recent_parent [winfo parent $W]`
293			`} else {`
294			`set _active $W,$tag`
295			`set help $_help_text($W,$tag)`
296
297			`# Switching on class name is bad. Do something better. Can't`
298			`# just use the widget's bbox method, because the results differ`
299			`# for Text and Canvas widgets. Bummer.`
300			`switch -- [winfo class $W] {`
301			`Menu {`
302			`# Recognize but do nothing.`
303			`}`
304
305			`Text {`
306			`lassign [$W bbox $tag.first] x y width height`
307			`set left [expr {[winfo rootx $W] + $x + round ($width * .75)}]`
308			`set ypos [expr {[winfo rooty $W] + $y + $height}]`
309			`set alt_ypos [expr {[winfo rooty $W] - $y}]`
310			`}`
311
312			`Canvas {`
313			`lassign [$W bbox $tag] x1 y1 x2 y2`
314			`# Must subtract out coordinates of top-left corner of canvas`
315			`# window; otherwise this will get the wrong position when`
316			`# the canvas has been scrolled.`
317			`set tlx [$W canvasx 0]`
318			`set tly [$W canvasy 0]`
319			`# Must round results because canvas coordinates are floats.`
320			`set left [expr {round ([winfo rootx $W] + $x1 - $tlx`
321			`+ ($x2 - $x1) * .75)}]`
322			`set ypos [expr {round ([winfo rooty $W] + $y2 - $tly)}]`
323			`set alt_ypos [expr {round ([winfo rooty $W] + $y1 - $tly)}]`
324			`}`
325
326			`default {`
327			`error "unrecognized window class for window \"$W\""`
328			`}`
329			`}`
330			`}`
331
332			`# On Windows, the popup location is always determined by the`
333			`# cursor. Actually, the rule seems to be somewhat more complex.`
334			`# Unfortunately it doesn't seem to be written down anywhere.`
335			`# Experiments show that the location is determined by the cursor`
336			`# if the text is wider than the widget; and otherwise it is`
337			`# centered under the widget. FIXME: we don't deal with those`
338			`# cases.`
339			`if {$tcl_platform(platform) == "windows"} then {`
340			`# FIXME: for now this is turned off. It isn't enough to get the`
341			`# cursor size; we actually have to find the bottommost "on"`
342			`# pixel in the cursor and use that for the height. I don't know`
343			`# how to do that.`
344			`# lassign [ide_cursor size] dummy height`
345			`# lassign [ide_cursor position] left ypos`
346			`# incr ypos $height`
347			`}`
348
349			`if {[info exists left] && $help != ""} then {`
350			`[namespace tail $this].label configure -text $help`
351			`set lw [winfo reqwidth [namespace tail $this].label]`
352			`set sw [winfo screenwidth [namespace tail $this]]`
353			`set bw [$this-win- cget -borderwidth]`
354			`if {$left + $lw + 2 * $bw >= $sw} then {`
355			`set left [expr {$sw - 2 * $bw - $lw}]`
356			`}`
357
358			`set lh [winfo reqheight [namespace tail $this].label]`
359			`if {$ypos + $lh >= [winfo screenheight [namespace tail $this]]} then {`
360			`set ypos [expr {$alt_ypos - $lh}]`
361			`}`
362
363			`wm positionfrom [namespace tail $this] user`
364			`wm geometry [namespace tail $this] +${left}+${ypos}`
365			`update`
366			`wm deiconify [namespace tail $this]`
367			`raise [namespace tail $this]`
368
369			`if {!$keep} {`
370			`# After 6 seconds, close the window. The timer is reset every`
371			`# time the window is shown.`
372			`after cancel [list $this _unshowballoon]`
373			`after 6000 [list $this _unshowballoon]`
374			`}`
375			`}`
376			`}`
377
378			`# This is run when a window or tag is destroyed. Private method.`
379			`method _subdestroy {W {tag {}}} {`
380			`if {$tag == ""} then {`
381			`# A window. Remove the window and any associated tags. Note`
382			`# that this is called for all Destroy events on descendents,`
383			`# even for windows which were never registered. Hence the use`
384			`# of catch.`
385			`catch {unset _help_text($W)}`
386			`foreach thing [array names _help_text($W,*)] {`
387			`unset _help_text($thing)`
388			`}`
389			`} else {`
390			`# Just a tag. This one can't be called by mistake, so this`
391			`# shouldn't need to be caught.`
392			`unset _help_text($W,$tag)`
393			`}`
394			`}`
395
396			`# This is run in response to a MenuSelect event on a menu.`
397			`method _motion {window name} {`
398			`# Decode window name.`
399			`regsub -all -- ! $name . name`
400
401			`if {$variable == ""} then {`
402			`# There's no point to doing anything.`
403			`return`
404			`}`
405
406			`set n [$window index active]`
407			`if {$n == "none"} then {`
408			`set index ""`
409			`set _active {}`
410			`} elseif {[info exists _help_text($name,$n)]} then {`
411			`# Tag specified by index number.`
412			`set index $name,$n`
413			`set _active $name,$n`
414			`} elseif {! [catch {$window entrycget $n -label} label]`
415			`&& [info exists _help_text($name,$label)]} then {`
416			`# Tag specified by index name.`
417			`set index $name,$label`
418			`set _active $name,$label`
419			`} else {`
420			`# No help for this item.`
421			`set index ""`
422			`set _active {}`
423			`}`
424
425			`_set_variable $index`
426			`}`
427
428			`# This is run when some widget unmaps. If the widget is the current`
429			`# widget, then unmap the balloon help. Private method.`
430			`method _unmap w {`
431			`if {$w == $_active} then {`
432			`_cancel`
433			`_unshowballoon`
434			`_set_variable {}`
435			`set _active {}`
436			`}`
437			`}`
438			`}`
439
440
441			`################################################################`
442
443			`# Find (and possibly create) balloon widget associated with window.`
444			`proc BALLOON_find_balloon {window} {`
445			`# Find our associated toplevel. If it is a menu, then keep going.`
446			`set top [winfo toplevel $window]`
447			`while {[winfo class $top] == "Menu"} {`
448			`set top [winfo toplevel [winfo parent $top]]`
449			`}`
450
451			`if {$top == "."} {`
452			`set bname .__balloon`
453			`} else {`
454			`set bname $top.__balloon`
455			`}`
456
457			`# If the balloon help for this toplevel doesn't exist, then create`
458			`# it. Yes, this relies on a magic name for the balloon help widget.`
459			`if {! [winfo exists $bname]} then {`
460			`Balloon $bname $top`
461			`}`
462			`return $bname`
463			`}`
464
465			`# This implements "balloon register".`
466			`proc BALLOON_command_register {window text {tag {}}} {`
467			`set b [BALLOON_find_balloon $window]`
468			`$b register $window $text $tag`
469			`}`
470
471			`# This implements "balloon notify".`
472			`proc BALLOON_command_notify {command window {tag {}}} {`
473			`set b [BALLOON_find_balloon $window]`
474			`$b notify $command $window $tag`
475			`}`
476
477			`# This implements "balloon show".`
478			`proc BALLOON_command_show {window {tag {}} {keep 0}} {`
479			`set b [BALLOON_find_balloon $window]`
480			`$b showballoon $window $tag $keep`
481			`}`
482
483			`proc BALLOON_command_withdraw {window} {`
484			`set b [BALLOON_find_balloon $window]`
485			`$b _unmap $window`
486			`}`
487
488			`# This implements "balloon variable".`
489			`proc BALLOON_command_variable {window args} {`
490			`if {[llength $args] == 0} then {`
491			`# Fetch.`
492			`set b [BALLOON_find_balloon [lindex $args 0]]`
493			`return [lindex [$b configure -variable] 4]`
494			`} else {`
495			`# FIXME: no arg checking here.`
496			`# Set.`
497			`set b [BALLOON_find_balloon $window]`
498			`$b configure -variable [lindex $args 0]`
499			`}`
500			`}`
501
502			`# The primary interface to balloon help.`
503			`# Usage:`
504			`# balloon notify COMMAND WINDOW ?TAG?`
505			`# Run COMMAND just before the help text for WINDOW (and TAG, if`
506			`# given) is displayed. If COMMAND is the empty string, then`
507			`# notification is disabled for this window.`
508			`# balloon register WINDOW TEXT ?TAG?`
509			`# Associate TEXT as the balloon help for WINDOW.`
510			`# If TAG is given, the use the appropriate tag for association.`
511			`# For menu widgets, TAG is a menu index.`
512			`# For canvas widgets, TAG is a tagOrId.`
513			`# For text widgets, TAG is a text index. If you want to use`
514			# the text tag FOO, use `FOO.last'.
515			`# balloon show WINDOW ?TAG?`
516			`# Immediately pop up the balloon for the given window and tag.`
517			`# This should be used sparingly. For instance, you might need to`
518			`# use it if the tag you're interested in does not track the mouse,`
519			`# but instead is added just before show-time.`
520			`# balloon variable WINDOW ?NAME?`
521			`# If NAME specified, set balloon help variable associated`
522			`# with window. This variable is set to the text whenever the`
523			`# balloon help is on. If NAME is specified but empty,`
524			`# no variable is set. If NAME not specified, then the`
525			`# current variable name is returned.`
526			`# balloon withdraw WINDOW`
527			`# Withdraw the balloon window associated with WINDOW. This should`
528			`# be used sparingly.`
529			`proc balloon {key args} {`
530			`if {[info commands BALLOON_command_$key] == "" } then {`
531			`error "unrecognized key \"$key\""`
532			`}`
533
534			`eval BALLOON_command_$key $args`
535			`}`