tcl/balloonhelp.tcl

   1 ## balloonhelp.tcl
   2 ## Balloon Help Routines
   3 ##
   4 ## Jeffrey Hobbs
   5 ## Initiated: 28 October 1996
   6 ##
   7
   8 ##------------------------------------------------------------------------
   9 ## PROCEDURE
  10 ##      balloonhelp
  11 ##
  12 ## DESCRIPTION
  13 ##      Implements a balloon help system
  14 ##
  15 ## ARGUMENTS
  16 ##      balloonhelp <option> ?arg?
  17 ##
  18 ## clear ?pattern?
  19 ##      Stops the specified widgets (defaults to all) from showing balloon
  20 ##      help.
  21 ##
  22 ## delay ?millisecs?
  23 ##      Query or set the delay.  The delay is in milliseconds and must
  24 ##      be at least 50.  Returns the delay.
  25 ##
  26 ## disable
  27 ##      Disables all balloon help.
  28 ##
  29 ## enable
  30 ##      Enables balloon help for defined widgets.
  31 ##
  32 ## <widget> ?-index index? ?message?
  33 ##      If -index is specified, then <widget> is assumed to be a menu
  34 ##      and the index represents what index into the menu (either the
  35 ##      numerical index or the label) to associate the balloon help
  36 ##      message with.  If message is {}, then the balloon help for that
  37 ##      widget is removed.  The widget must exist prior to calling
  38 ##      balloonhelp.  The current balloon help message for <widget> is
  39 ##      returned, if any.
  40 ##
  41 ## RETURNS: varies (see methods above)
  42 ##
  43 ## NAMESPACE & STATE
  44 ##      The global array BalloonHelp is used.  Procs begin with BalloonHelp.
  45 ## The overrideredirected toplevel is named $BalloonHelp(TOPLEVEL).
  46 ##
  47 ## EXAMPLE USAGE:
  48 ##      balloonhelp .button "A Button"
  49 ##      balloonhelp .menu -index "Load" "Loads a file"
  50 ##
  51 ##------------------------------------------------------------------------
  52
  53 ## An alternative to binding to all would be to bind to BalloonHelp
  54 ## and add that to the bindtags of each widget registered.
  55
  56 ## The extra :hide call in <Enter> is necessary to catch moving to
  57 ## child widgets where the <Leave> event won't be generated
  58 bind all <Enter> {
  59     #BalloonHelp:hide
  60     set BalloonHelp(LAST) -1
  61     if {$BalloonHelp(enabled) && [info exists BalloonHelp(%W)]} {
  62         set BalloonHelp(AFTERID) [after $BalloonHelp(DELAY) \
  63                 [list BalloonHelp:show %W $BalloonHelp(%W)]]
  64     }
  65 }
  66 bind BalloonsMenu <Any-Motion> {
  67     if {$BalloonHelp(enabled)} {
  68         set cur [%W index active]
  69         if {$cur == $BalloonHelp(LAST)} return
  70         set BalloonHelp(LAST) $cur
  71         BalloonHelp:hide
  72         if {[info exists BalloonHelp(%W,$cur)] || \
  73                 (![catch {%W entrycget $cur -label} cur] && \
  74                 [info exists BalloonHelp(%W,$cur)])} {
  75             set BalloonHelp(AFTERID) [after $BalloonHelp(DELAY) \
  76                     [list BalloonHelp:show %W $BalloonHelp(%W,$cur) $cur]]
  77         }
  78     }
  79 }
  80 bind all <Leave>                { BalloonHelp:hide }
  81 bind Balloons <Any-KeyPress>    { BalloonHelp:hide }
  82 bind Balloons <Any-Button>      { BalloonHelp:hide }
  83 array set BalloonHelp {
  84     enabled     1
  85     DELAY       500
  86     AFTERID     {}
  87     LAST        -1
  88     TOPLEVEL    .__balloonhelp__
  89 }
  90
  91 proc balloonhelp {w args} {
  92     global BalloonHelp
  93     switch -- $w {
  94         clear   {
  95             if {[llength $args]==0} { set args .* }
  96             BalloonHelp:clear $args
  97         }
  98         delay   {
  99             if {[llength $args]} {
 100                 if {![regexp {^[0-9]+$} $args] || $args<50} {
 101                     return -code error "BalloonHelp delay must be an\
 102                             integer greater than 50 (delay is in millisecs)"
 103                 }
 104                 return [set BalloonHelp(DELAY) $args]
 105             } else {
 106                 return $BalloonHelp(DELAY)
 107             }
 108         }
 109         disable {
 110             set BalloonHelp(enabled) 0
 111             BalloonHelp:hide
 112         }
 113         enable  {
 114             set BalloonHelp(enabled) 1
 115         }
 116         default {
 117             if {[llength $args]} {
 118                 set i [uplevel BalloonHelp:register $w $args]
 119             }
 120             set b $BalloonHelp(TOPLEVEL)
 121             if {![winfo exists $b]} {
 122                 toplevel $b
 123                 wm overrideredirect $b 1
 124                 wm positionfrom $b program
 125                 wm withdraw $b
 126                 pack [label $b.l -highlightthickness 0 -relief raised -bd 1 \
 127                         -background yellow]
 128             }
 129             if {[info exists BalloonHelp($i)]} { return $BalloonHelp($i) }
 130         }
 131     }
 132 }
 133
 134 ;proc BalloonHelp:register {w args} {
 135     global BalloonHelp
 136     set key [lindex $args 0]
 137     while {[string match -* $key]} {
 138         switch -- $key {
 139             -index      {
 140                 if {[catch {$w entrycget 1 -label}]} {
 141                     return -code error "widget \"$w\" does not seem to be a\
 142                             menu, which is required for the -index switch"
 143                 }
 144                 set index [lindex $args 1]
 145                 set args [lreplace $args 0 1]
 146             }
 147             default     {
 148                 return -code error "unknown option \"$key\": should be -index"
 149             }
 150         }
 151         set key [lindex $args 0]
 152     }
 153     if {[llength $args] != 1} {
 154         return -code error "wrong \# args: should be \"balloonhelp widget\
 155                 ?-index index? message\""
 156     }
 157     if {[string match {} $key]} {
 158         BalloonHelp:clear $w
 159     } else {
 160         if {![winfo exists $w]} {
 161             return -code error "bad window path name \"$w\""
 162         }
 163         if {[info exists index]} {
 164             set BalloonHelp($w,$index) $key
 165             bindtags $w [linsert [bindtags $w] end BalloonsMenu]
 166             return $w,$index
 167         } else {
 168             set BalloonHelp($w) $key
 169             bindtags $w [linsert [bindtags $w] end Balloons]
 170             return $w
 171         }
 172     }
 173 }
 174
 175 ;proc BalloonHelp:clear {{pattern .*}} {
 176     global BalloonHelp
 177     foreach w [array names BalloonHelp $pattern] {
 178         unset BalloonHelp($w)
 179         if {[winfo exists $w]} {
 180             set tags [bindtags $w]
 181             if {[set i [lsearch $tags Balloons]] != -1} {
 182                 bindtags $w [lreplace $tags $i $i]
 183             }
 184             ## We don't remove BalloonsMenu because there
 185             ## might be other indices that use it
 186         }
 187     }
 188 }
 189
 190 ;proc BalloonHelp:show {w msg {i {}}} {
 191     if {![winfo exists $w] || [string compare \
 192             $w [eval winfo containing [winfo pointerxy $w]]]} return
 193
 194     global BalloonHelp
 195     set b $BalloonHelp(TOPLEVEL)
 196     $b.l configure -text $msg
 197     update idletasks
 198     if {[string compare {} $i]} {
 199         set y [expr [winfo rooty $w]+[$w yposition $i]+25]
 200         if {($y+[winfo reqheight $b])>[winfo screenheight $w]} {
 201             set y [expr [winfo rooty $w]+[$w yposition $i]-\
 202                     [winfo reqheight $b]-5]
 203         }
 204     } else {
 205         set y [expr [winfo rooty $w]+[winfo height $w]+5]
 206         if {($y+[winfo reqheight $b])>[winfo screenheight $w]} {
 207             set y [expr [winfo rooty $w]-[winfo reqheight $b]-5]
 208         }
 209     }
 210     set x [expr [winfo rootx $w]+([winfo width $w]-[winfo reqwidth $b])/2]
 211     if {$x<0} {
 212         set x 0
 213     } elseif {($x+[winfo reqwidth $b])>[winfo screenwidth $w]} {
 214         set x [expr [winfo screenwidth $w]-[winfo reqwidth $b]]
 215     }
 216     wm geometry $b +$x+$y
 217     wm deiconify $b
 218     raise $b
 219 }
 220
 221 ;proc BalloonHelp:hide {args} {
 222     global BalloonHelp
 223     after cancel $BalloonHelp(AFTERID)
 224     catch {wm withdraw $BalloonHelp(TOPLEVEL)}
 225 }