| # 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] |
| |
| 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 |
| 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 |
| } |