Posted to tcl by dburns at Tue Jan 25 00:27:25 GMT 2011view raw
- # BubbleHelp
- #
- # Args: <widget> [<tag>] <help-text>
- #
- # Sets up bindings so that when the mouse-cursor moves into <widget>, a bubble-help window
- # appears showing <help-text> after the mouse has hovered for a while.
- #
- # If <help-text> is empty, then any existing bindings are removed.
- #
- # Most of the heavy-lifting is done by the tcl procedure "BubbleHelp" bound to the widget's
- # event stream.
- #
- proc BindBubbleHelp { w tag htext } {
- # Removing existing bindings?
- if { [string length $htext] == 0 } {
- # Did the user pass in a tag?
- if { [string length $tag] == 0 } {
- # Nope - Just bind to the widget
- #
- # Delete the bindings
- bind $w <Enter> {}
- bind $w <Leave> {}
- bind $w <Motion> {}
- } \
- else {
- # Yes: - They passed in a tag, the widget must be a text widget
- #
- $w tag bind $tag <Enter> {}
- $w tag bind $tag <Leave> {}
- $w tag bind $tag <Motion> {}
- }
- # That's it!
- return
- }
- # Did the user pass in a tag?
- if { [string length $tag] == 0 } {
- # Nope - Just bind to the widget
- #
- # Set up the necessary bindings
- bind $w <Enter> { BubbleHelp ENTER %W "" "" "" }
- bind $w <Leave> { BubbleHelp LEAVE %W "" "" "" }
- bind $w <Motion> [list BubbleHelp MOTION %W %X %Y $htext]
- } \
- else {
- # Yes: - They passed in a tag, the widget must be a text widget
- #
- $w tag bind $tag <Enter> {BubbleHelp ENTER %W "" "" "T" }
- $w tag bind $tag <Leave> {BubbleHelp LEAVE %W "" "" "T" }
- $w tag bind $tag <Motion> [list BubbleHelp MOTION %W %X %Y $htext]
- }
- # Initialize state to 'empty' if we haven't before
- global BHS_cds
- if { ![info exists BHS_cds(lastEntered)] } {
- set BHS_cds(lastEntered) ""
- unset -nocomplain BHS_cds(timerID)
- unset -nocomplain BHS_cds(floatingWW)
- }
- }
- # BubbleHelp
- # BubbleHelp - Handles Mouse movement events for Bubble Help
- # BubbleHelp
- #
- #==============================================================================
- #
- # HELPER PURPOSE:
- # This function handles events for movement of the mouse within the
- # widget selected for bubble-help support by G_BIND_BUBBLEHELP
- #
- # ARGUMENTS:
- # Entered from these different events (three Tk window-generated,
- # our internal TIMER event.
- #
- # Event type w X Y text
- # -------- ------------------------
- # <Enter> ENTER %W - - T
- # <Leave> LEAVE %W - - T
- # <Motion> MOTION %W %X %Y <text-string>
- # [after] TIMER %W - - -
- #
- # X and Y coordinates of the mouse in WIDGET-COORDINATES.
- # W is the widget. "T" is either empty, or "T" which means
- # the binding is for a tag in a text widget and the cursor
- # shape needs to be modified.
- #
- # MESSAGES ISSUED:
- # ----------------
- # None.
- #
- # OTHER THINGS TO KNOW:
- #
- # The Mx and My coordinates are relative to the bound widget.
- #
- # The effect we're supposed to achieve is the popping up of a small bubble-help
- # window (containing the help-text) after the mouse cursor has entered
- # within the bounds of the widget for a short period of time. After the bubble-help
- # window is popped up, it stays there for five seconds (while the cursor is in the widget)
- # widget, or until the cursor moves into another widget. Once the bubble-help window has been
- # taken down, it's supposed to stay down as long as the cursor remains within the
- # widget (even if it moves a bit).
- #
- # State maintained within array "BHS_cds" is made up of:
- #
- # Index Purpose
- # ----- -------
- # lastEntered String name of the last-entered widget, otherwise "" if none.
- # timerID If a timer has been started due to entry into "lastEntered",
- # the "after id" appears here, otherwise it is undefined.
- # floatingWW Window widget for the floating bubblehelp window.
- #==============================================================================
- proc BubbleHelp { type W X Y htext} {
- global BHS_cds
- # What kind of entry are we dealing with?
- switch $type {
- "ENTER" {
- # We use the arrival of an ENTER event merely to check to see if
- # we need to kill an existing bubblehelp window that was put up for
- # a DIFFERENT widget than the one for which the ENTER was sent.
- # (We depend on the arrival of a corresponding MOTION event to
- # actually cause the bubblehelp window to appear for this widget.)
- # If the "last-entered" widget is known AND is different from "W"...
- if { ![string length $BHS_cds(lastEntered)] == 0 && \
- ![string equal $BHS_cds(lastEntered) $W] } {
- # Cancel any timer for the previous widget that might be ticking
- if { [info exists BHS_cds(timerID)] } {
- after cancel $BHS_cds(timerID)
- unset BHS_cds(timerID)
- }
- # Take down any bubble-help window we may have still up
- if { [info exists BHS_cds(floatingWW)] } {
- destroy $BHS_cds(floatingWW)
- unset BHS_cds(floatingWW)
- }
- # Show us in an "un-ENTERed" state, even as we expect the imminent
- # arrival of a MOTION event within this widget.
- set BHS_cds(lastEntered) ""
- }
- # If we're entering a "tagged" section of a text widget
- if { [string equal $htext "T"] } {
- # Convert the cursor back to normal
- $W configure -cursor arrow
- }
- }
- "LEAVE" {
- # We simply shut-down anything going on for this widget.
- # If the "last-entered" widget is known AND is the SAME AS "W"...
- if { ![string length $BHS_cds(lastEntered)] == 0 && \
- [string equal $BHS_cds(lastEntered) $W] } {
- # Cancel any timer for the previous widget that might be ticking
- if { [info exists BHS_cds(timerID)] } {
- after cancel $BHS_cds(timerID)
- unset BHS_cds(timerID)
- }
- # Take down any bubble-help window we may have still up
- if { [info exists BHS_cds(floatingWW)] } {
- destroy $BHS_cds(floatingWW)
- unset BHS_cds(floatingWW)
- }
- # Mark the fact that the cursor has passed OUT OF this particular widget
- set BHS_cds(lastEntered) ""
- # If we're leaving a "tagged" section of a text widget
- if { [string equal $htext "T"] } {
- # Revert the cursor back to normal for a text widget
- $W configure -cursor xterm
- }
- }
- }
- "MOTION" {
- # Take care of blowing off a previous help window for which we missed the
- # LEAVE event...
- #
- # If the "last-entered" widget is known AND is different from "W"...
- if { ![string length $BHS_cds(lastEntered)] == 0 && \
- ![string equal $BHS_cds(lastEntered) $W] } {
- # Simulate a LEAVE event
- BubbleHelp LEAVE $BHS_cds(lastEntered) fake fake fake
- }
- # We want the first MOTION event for this widget to cause the bubblehelp
- # window to go up. If "lastEntered" is currently "", then we infer it's
- # the first MOTION event for this widget.
- if { [string length $BHS_cds(lastEntered)] == 0 } {
- # Window must be created...
- #
- # Does it exist now?
- if { ![info exists BHS_cds(floatingWW)] } {
- # Nope, create the Floating Window
- set BHS_cds(floatingWW) ".bubblehelp"
- toplevel $BHS_cds(floatingWW) -bg yellow
- wm overrideredirect $BHS_cds(floatingWW) 1
- global tcl_platform
- if { [string equal "windows" $tcl_platform(platform)] } {
- wm attributes $BHS_cds(floatingWW) -topmost 1
- }
- # Put in the label that gets filled with the summary of the session
- set f [frame $BHS_cds(floatingWW).frame -bd 1 -bg black]
- label $f.label \
- -borderwidth 2 -bg yellow \
- -font {-*-MS Sans Serif-Medium-R-Normal-*-*-80-*-*-*-*-*-*} \
- -justify left -relief flat
- pack $f $f.label -side left
- }
- # Update the contents of the window (and it's position)
- $BHS_cds(floatingWW).frame.label configure -text $htext
- # Position it according to Mouse Coordinates passed and size computed
- set xoffset 0 ; set yoffset 32 ; set height 30
- set x [expr $X + $xoffset ]
- set y [expr $Y + $yoffset ]
- # Now diddle Y if we're too near the bottom of the screen.
- #
- # If the top of the window (x,y) is closer than "height" to the screen size,
- # flip the window to float above the cursor rather than below.
- #
- if { $y > ( [winfo screenheight .] - $height ) } {
- set y [expr $y - $yoffset - $height]
- }
- #----Bug in 8.4.4 under XP with multiple-screens, screen width is incorrect.
- # Likewise diddle X if we're too near the right hand side of the screen
- # set width [winfo reqwidth $BHS_cds(floatingWW)]
- # set scrnwidth [winfo screenwidth .]
- # if { $x+$width > $scrnwidth } {
- # set x [expr {$scrnwidth - $width}]
- # }
- wm geometry $BHS_cds(floatingWW) +$x+$y
- # Start a timer to make the window come down.
- set BHS_cds(timerID) [after 5000 BubbleHelp TIMER $W fake fake fake]
- # Show us officially "entered"
- set BHS_cds(lastEntered) "$W"
- }
- # If we reach here, it's another MOTION event for the current widget..
- # nothing to do.
- }
- "TIMER" {
- # The cursor has hovered for the required amount of time in the
- # widget. If the cursor is still in the window, "Do Our Thing".
- # If the timer still lurks, dump it
- if { [info exists BHS_cds(timerID)] } {
- after cancel $BHS_cds(timerID)
- unset BHS_cds(timerID)
- }
- # If the bubble window is already up... (it should be)
- if { [info exists BHS_cds(floatingWW)] } {
- # Take it down
- destroy $BHS_cds(floatingWW)
- unset BHS_cds(floatingWW)
- }
- }
- }
- }