libgui/library/balloon.tcl

   1 # 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       if {$variable != ""} {
 264         upvar $variable var
 265         set var $_help_text($index)
 266       }
 267       set _in_notifier 1
 268       uplevel \#0 $_notifiers($index)
 269       set _in_notifier 0
 270       # Get value afterwards to give notifier a chance to change it.
 271       if {$variable != ""} {
 272         upvar $variable var
 273         set _help_text($index) $var
 274       }
 275       set value $_help_text($index)
 276     } else {
 277       set value $_help_text($index)
 278     }
 279
 280     if {$variable != ""} then {
 281       upvar $variable var
 282       set var $value
 283     }
 284   }
 285
 286   # This is run to show the balloon.  Private method.
 287   method showballoon {W tag {keep 0}} {
 288     global tcl_platform
 289
 290     if {$tag == ""} then {
 291       # An ordinary window.  Position below the window, and right of
 292       # center.
 293       set _active $W
 294       set left [expr {[winfo rootx $W] + round ([winfo width $W] * .75)}]
 295       set ypos [expr {[winfo rooty $W] + [winfo height $W]}]
 296       set alt_ypos [winfo rooty $W]
 297
 298       # Balloon shown, so set parent info.
 299       set _recent_parent [winfo parent $W]
 300     } else {
 301       set _active $W,$tag
 302       # Switching on class name is bad.  Do something better.  Can't
 303       # just use the widget's bbox method, because the results differ
 304       # for Text and Canvas widgets.  Bummer.
 305       switch -- [winfo class $W] {
 306         Menu {
 307           # Recognize but do nothing.
 308         }
 309
 310         Text {
 311           lassign [$W bbox $tag.first] x y width height
 312           set left [expr {[winfo rootx $W] + $x + round ($width * .75)}]
 313           set ypos [expr {[winfo rooty $W] + $y + $height}]
 314           set alt_ypos [expr {[winfo rooty $W] - $y}]
 315         }
 316
 317         Canvas {
 318           lassign [$W bbox $tag] x1 y1 x2 y2
 319           # Must subtract out coordinates of top-left corner of canvas
 320           # window; otherwise this will get the wrong position when
 321           # the canvas has been scrolled.
 322           set tlx [$W canvasx 0]
 323           set tly [$W canvasy 0]
 324           # Must round results because canvas coordinates are floats.
 325           set left [expr {round ([winfo rootx $W] + $x1 - $tlx
 326                                  + ($x2 - $x1) * .75)}]
 327           set ypos [expr {round ([winfo rooty $W] + $y2 - $tly)}]
 328           set alt_ypos [expr {round ([winfo rooty $W] + $y1 - $tly)}]
 329         }
 330
 331         default {
 332           error "unrecognized window class for window \"$W\""
 333         }
 334       }
 335     }
 336
 337     set help $_help_text($_active)
 338
 339     # On Windows, the popup location is always determined by the
 340     # cursor.  Actually, the rule seems to be somewhat more complex.
 341     # Unfortunately it doesn't seem to be written down anywhere.
 342     # Experiments show that the location is determined by the cursor
 343     # if the text is wider than the widget; and otherwise it is
 344     # centered under the widget.  FIXME: we don't deal with those
 345     # cases.
 346     if {$tcl_platform(platform) == "windows"} then {
 347       # FIXME: for now this is turned off.  It isn't enough to get the
 348       # cursor size; we actually have to find the bottommost "on"
 349       # pixel in the cursor and use that for the height.  I don't know
 350       # how to do that.
 351       # lassign [ide_cursor size] dummy height
 352       # lassign [ide_cursor position] left ypos
 353       # incr ypos $height
 354     }
 355
 356     if {[info exists left] && $help != ""} then {
 357       [namespace tail $this].label configure -text $help
 358       set lw [winfo reqwidth [namespace tail $this].label]
 359       set sw [winfo screenwidth [namespace tail $this]]
 360       set bw [$this-win- cget -borderwidth]
 361       if {$left + $lw + 2 * $bw >= $sw} then {
 362         set left [expr {$sw - 2 * $bw - $lw}]
 363       }
 364
 365       set lh [winfo reqheight [namespace tail $this].label]
 366       if {$ypos + $lh >= [winfo screenheight [namespace tail $this]]} then {
 367         set ypos [expr {$alt_ypos - $lh}]
 368       }
 369
 370       wm positionfrom  [namespace tail $this] user
 371       wm geometry  [namespace tail $this] +${left}+${ypos}
 372       update
 373       wm deiconify  [namespace tail $this]
 374       raise  [namespace tail $this]
 375
 376       if {!$keep} {
 377         # After 6 seconds, close the window.  The timer is reset every
 378         # time the window is shown.
 379         after cancel [list $this _unshowballoon]
 380         after 6000 [list $this _unshowballoon]
 381       }
 382     }
 383   }
 384
 385   # This is run when a window or tag is destroyed.  Private method.
 386   method _subdestroy {W {tag {}}} {
 387     if {$tag == ""} then {
 388       # A window.  Remove the window and any associated tags.  Note
 389       # that this is called for all Destroy events on descendents,
 390       # even for windows which were never registered.  Hence the use
 391       # of catch.
 392       catch {unset _help_text($W)}
 393       foreach thing [array names _help_text($W,*)] {
 394         unset _help_text($thing)
 395       }
 396     } else {
 397       # Just a tag.  This one can't be called by mistake, so this
 398       # shouldn't need to be caught.
 399       unset _help_text($W,$tag)
 400     }
 401   }
 402
 403   # This is run in response to a MenuSelect event on a menu.
 404   method _motion {window name} {
 405     # Decode window name.
 406     regsub -all -- ! $name . name
 407
 408     if {$variable == ""} then {
 409       # There's no point to doing anything.
 410       return
 411     }
 412
 413     set n [$window index active]
 414     if {$n == "none"} then {
 415       set index ""
 416       set _active {}
 417     } elseif {[info exists _help_text($name,$n)]} then {
 418       # Tag specified by index number.
 419       set index $name,$n
 420       set _active $name,$n
 421     } elseif {! [catch {$window entrycget $n -label} label]
 422               && [info exists _help_text($name,$label)]} then {
 423       # Tag specified by index name.
 424       set index $name,$label
 425       set _active $name,$label
 426     } else {
 427       # No help for this item.
 428       set index ""
 429       set _active {}
 430     }
 431
 432     _set_variable $index
 433   }
 434
 435   # This is run when some widget unmaps.  If the widget is the current
 436   # widget, then unmap the balloon help.  Private method.
 437   method _unmap w {
 438     if {$w == $_active} then {
 439       _cancel
 440       _unshowballoon
 441       _set_variable {}
 442       set _active {}
 443     }
 444   }
 445 }
 446
 447
 448 ################################################################
 449
 450 # Find (and possibly create) balloon widget associated with window.
 451 proc BALLOON_find_balloon {window} {
 452   # Find our associated toplevel.  If it is a menu, then keep going.
 453   set top [winfo toplevel $window]
 454   while {[winfo class $top] == "Menu"} {
 455     set top [winfo toplevel [winfo parent $top]]
 456   }
 457
 458   if {$top == "."} {
 459     set bname .__balloon
 460   } else {
 461     set bname $top.__balloon
 462   }
 463
 464   # If the balloon help for this toplevel doesn't exist, then create
 465   # it.  Yes, this relies on a magic name for the balloon help widget.
 466   if {! [winfo exists $bname]} then {
 467     Balloon $bname $top
 468   }
 469   return $bname
 470 }
 471
 472 # This implements "balloon register".
 473 proc BALLOON_command_register {window text {tag {}}} {
 474   set b [BALLOON_find_balloon $window]
 475   $b register $window $text $tag
 476 }
 477
 478 # This implements "balloon notify".
 479 proc BALLOON_command_notify {command window {tag {}}} {
 480   set b [BALLOON_find_balloon $window]
 481   $b notify $command $window $tag
 482 }
 483
 484 # This implements "balloon show".
 485 proc BALLOON_command_show {window {tag {}} {keep 0}} {
 486   set b [BALLOON_find_balloon $window]
 487   $b showballoon $window $tag $keep
 488 }
 489
 490 proc BALLOON_command_withdraw {window} {
 491   set b [BALLOON_find_balloon $window]
 492   $b _unmap $window
 493 }
 494
 495 # This implements "balloon variable".
 496 proc BALLOON_command_variable {window args} {
 497   if {[llength $args] == 0} then {
 498     # Fetch.
 499     set b [BALLOON_find_balloon $window]
 500     return [$b cget -variable]
 501   } else {
 502     # FIXME: no arg checking here.
 503     # Set.
 504     set b [BALLOON_find_balloon $window]
 505     $b configure -variable [lindex $args 0]
 506   }
 507 }
 508
 509 # The primary interface to balloon help.
 510 # Usage:
 511 #  balloon notify COMMAND WINDOW ?TAG?
 512 #    Run COMMAND just before the help text for WINDOW (and TAG, if
 513 #    given) is displayed.  If COMMAND is the empty string, then
 514 #    notification is disabled for this window.
 515 #  balloon register WINDOW TEXT ?TAG?
 516 #    Associate TEXT as the balloon help for WINDOW.
 517 #    If TAG is given, the use the appropriate tag for association.
 518 #    For menu widgets, TAG is a menu index.
 519 #    For canvas widgets, TAG is a tagOrId.
 520 #    For text widgets, TAG is a text index.  If you want to use
 521 #      the text tag FOO, use `FOO.last'.
 522 #  balloon show WINDOW ?TAG?
 523 #    Immediately pop up the balloon for the given window and tag.
 524 #    This should be used sparingly.  For instance, you might need to
 525 #    use it if the tag you're interested in does not track the mouse,
 526 #    but instead is added just before show-time.
 527 #  balloon variable WINDOW ?NAME?
 528 #    If NAME specified, set balloon help variable associated
 529 #    with window.  This variable is set to the text whenever the
 530 #    balloon help is on.  If NAME is specified but empty,
 531 #    no variable is set.  If NAME not specified, then the
 532 #    current variable name is returned.
 533 #  balloon withdraw WINDOW
 534 #    Withdraw the balloon window associated with WINDOW.  This should
 535 #    be used sparingly.
 536 proc balloon {key args} {
 537   if {[info commands BALLOON_command_$key] == "" } then {
 538     error "unrecognized key \"$key\""
 539   }
 540
 541   eval BALLOON_command_$key $args
 542 }