git.zerfleddert.de Git - micropolis/blob - src/tk/library/menu.tcl

   1 # menu.tcl --
   2 #
   3 # This file contains Tcl procedures used to manage Tk menus and
   4 # menubuttons.  Most of the code here is dedicated to support for
   5 # menu traversal via the keyboard.
   6 #
   7 # $Header: /user6/ouster/wish/scripts/RCS/menu.tcl,v 1.11 92/08/08 14:49:55 ouster Exp $ SPRITE (Berkeley)
   8 #
   9 # Copyright 1992 Regents of the University of California
  10 # Permission to use, copy, modify, and distribute this
  11 # software and its documentation for any purpose and without
  12 # fee is hereby granted, provided that this copyright
  13 # notice appears in all copies.  The University of California
  14 # makes no representations about the suitability of this
  15 # software for any purpose.  It is provided "as is" without
  16 # express or implied warranty.
  17 #
  18
  19 # The procedure below is publically available.  It is used to indicate
  20 # the menus associated with a particular top-level window, for purposes
  21 # of keyboard menu traversal.  Its first argument is the path name of
  22 # a top-level window, and any additional arguments are the path names of
  23 # the menu buttons associated with that top-level window, in the order
  24 # they should be traversed.  If no menu buttons are named, the procedure
  25 # returns the current list of menus for w.  If a single empty string is
  26 # supplied, then the menu list for w is cancelled.  Otherwise, tk_menus
  27 # sets the menu list for w to the menu buttons.
  28
  29 proc tk_menus {w args} {
  30     global tk_priv
  31
  32     if {$args == ""} {
  33         if [catch {set result [set tk_priv(menusFor$w)]}] {
  34             return ""
  35         }
  36         return $result
  37     }
  38
  39     if {$args == "{}"} {
  40         catch {unset tk_priv(menusFor$w)}
  41         return ""
  42     }
  43
  44     set tk_priv(menusFor$w) $args
  45 }
  46
  47 # The procedure below is publically available.  It takes any number of
  48 # arguments taht are names of widgets or classes.  It sets up bindings
  49 # for the widgets or classes so that keyboard menu traversal is possible
  50 # when the input focus is in those widgets or classes.
  51
  52 proc tk_bindForTraversal args {
  53     foreach w $args {
  54         bind $w <Alt-KeyPress> {tk_traverseToMenu %W %A}
  55         bind $w <F10> {tk_firstMenu %W}
  56     }
  57 }
  58
  59 # The procedure below does all of the work of posting a menu (including
  60 # unposting any other menu that might currently be posted).  The "w"
  61 # argument is the name of the menubutton for the menu to be posted.
  62 # Note:  if $w is disabled then the procedure does nothing.
  63
  64 proc tk_mbPost {w} {
  65     global tk_priv tk_strictMotif
  66     if {[lindex [$w config -state] 4] == "disabled"} {
  67         return
  68     }
  69     set cur $tk_priv(posted)
  70     if {$cur == $w} {
  71         return
  72     }
  73     if {$cur != ""} tk_mbUnpost
  74     set tk_priv(relief) [lindex [$w config -relief] 4]
  75     $w config -relief raised
  76     set tk_priv(cursor) [lindex [$w config -cursor] 4]
  77     $w config -cursor arrow
  78     $w post
  79     grab -global $w
  80     set tk_priv(posted) $w
  81     if {$tk_priv(focus) == ""} {
  82         set tk_priv(focus) [focus]
  83     }
  84     set menu [lindex [$w config -menu] 4]
  85     set tk_priv(activeBg) [lindex [$menu config -activebackground] 4]
  86     set tk_priv(activeFg) [lindex [$menu config -activeforeground] 4]
  87     if $tk_strictMotif {
  88         $menu config -activebackground [lindex [$menu config -background] 4]
  89         $menu config -activeforeground [lindex [$menu config -foreground] 4]
  90     }
  91     focus $menu
  92 }
  93
  94 # The procedure below does all the work of unposting the menubutton that's
  95 # currently posted.  It takes no arguments.
  96
  97 proc tk_mbUnpost {} {
  98     global tk_priv
  99     if {$tk_priv(posted) != ""} {
 100         $tk_priv(posted) config -relief $tk_priv(relief)
 101         $tk_priv(posted) config -cursor $tk_priv(cursor)
 102         $tk_priv(posted) config -activebackground $tk_priv(activeBg)
 103         $tk_priv(posted) config -activeforeground $tk_priv(activeFg)
 104         $tk_priv(posted) unpost
 105 # deh multi display bug fix
 106 #       grab none
 107         set menu [lindex [$tk_priv(posted) config -menu] 4]
 108         grab -off $menu
 109         focus $tk_priv(focus)
 110         set tk_priv(focus) ""
 111         $menu config -activebackground $tk_priv(activeBg)
 112         $menu config -activeforeground $tk_priv(activeFg)
 113         set tk_priv(posted) {}
 114     }
 115 }
 116
 117 # The procedure below is invoked to implement keyboard traversal to
 118 # a menu button.  It takes two arguments:  the name of a window where
 119 # a keystroke originated, and the ascii character that was typed.
 120 # This procedure finds a menu bar by looking upward for a top-level
 121 # window, then looking for a window underneath that named "menu".
 122 # Then it searches through all the subwindows of "menu" for a menubutton
 123 # with an underlined character matching char.  If one is found, it
 124 # posts that menu.
 125
 126 proc tk_traverseToMenu {w char} {
 127     global tk_priv
 128     if {$char == ""} {
 129         return
 130     }
 131     set char [string tolower $char]
 132
 133     foreach mb [tk_getMenuButtons $w] {
 134         if {[winfo class $mb] == "Menubutton"} {
 135             set char2 [string index [lindex [$mb config -text] 4] \
 136                     [lindex [$mb config -underline] 4]]
 137             if {[string compare $char [string tolower $char2]] == 0} {
 138                 tk_mbPost $mb
 139                 [lindex [$mb config -menu] 4] activate 0
 140                 return
 141             }
 142         }
 143     }
 144 }
 145
 146 # The procedure below is used to implement keyboard traversal within
 147 # the posted menu.  It takes two arguments:  the name of the menu to
 148 # be traversed within, and an ASCII character.  It searches for an
 149 # entry in the menu that has that character underlined.  If such an
 150 # entry is found, it is invoked and the menu is unposted.
 151
 152 proc tk_traverseWithinMenu {w char} {
 153     if {$char == ""} {
 154         return
 155     }
 156     set char [string tolower $char]
 157     set last [$w index last]
 158     for {set i 0} {$i <= $last} {incr i} {
 159         if [catch {set char2 [string index \
 160                 [lindex [$w entryconfig $i -label] 4] \
 161                 [lindex [$w entryconfig $i -underline] 4]]}] {
 162             continue
 163         }
 164         if {[string compare $char [string tolower $char2]] == 0} {
 165             tk_mbUnpost
 166             $w invoke $i
 167             return
 168         }
 169     }
 170 }
 171
 172 # The procedure below takes a single argument, which is the name of
 173 # a window.  It returns a list containing path names for all of the
 174 # menu buttons associated with that window's top-level window, or an
 175 # empty list if there are none.
 176
 177 proc tk_getMenuButtons w {
 178     global tk_priv
 179     set top [winfo toplevel $w]
 180     if [catch {set buttons [set tk_priv(menusFor$top)]}] {
 181         return ""
 182     }
 183     return $buttons
 184 }
 185
 186 # The procedure below is used to traverse to the next or previous
 187 # menu in a menu bar.  It takes one argument, which is a count of
 188 # how many menu buttons forward or backward (if negative) to move.
 189 # If there is no posted menu then this procedure has no effect.
 190
 191 proc tk_nextMenu count {
 192     global tk_priv
 193     if {$tk_priv(posted) == ""} {
 194         return
 195     }
 196     set buttons [tk_getMenuButtons $tk_priv(posted)]
 197     set length [llength $buttons]
 198     for {set i 0} 1 {incr i} {
 199         if {$i >= $length} {
 200             return
 201         }
 202         if {[lindex $buttons $i] == $tk_priv(posted)} {
 203             break
 204         }
 205     }
 206     incr i $count
 207     while 1 {
 208         while {$i < 0} {
 209             incr i $length
 210         }
 211         while {$i >= $length} {
 212             incr i -$length
 213         }
 214         set mb [lindex $buttons $i]
 215         if {[lindex [$mb configure -state] 4] != "disabled"} {
 216             break
 217         }
 218         incr i $count
 219     }
 220     tk_mbUnpost
 221     tk_mbPost $mb
 222     [lindex [$mb config -menu] 4] activate 0
 223 }
 224
 225 # The procedure below is used to traverse to the next or previous entry
 226 # in the posted menu.  It takes one argument, which is 1 to go to the
 227 # next entry or -1 to go to the previous entry.  Disabled entries are
 228 # skipped in this process.
 229
 230 proc tk_nextMenuEntry count {
 231     global tk_priv
 232     if {$tk_priv(posted) == ""} {
 233         return
 234     }
 235     set menu [lindex [$tk_priv(posted) config -menu] 4]
 236     set length [expr [$menu index last]+1]
 237     set i [$menu index active]
 238     if {$i == "none"} {
 239         set i 0
 240     } else {
 241         incr i $count
 242     }
 243     while 1 {
 244         while {$i < 0} {
 245             incr i $length
 246         }
 247         while {$i >= $length} {
 248             incr i -$length
 249         }
 250         if {[catch {$menu entryconfigure $i -state} state] == 0} {
 251             if {[lindex $state 4] != "disabled"} {
 252                 break
 253             }
 254         }
 255         incr i $count
 256     }
 257     $menu activate $i
 258 }
 259
 260 # The procedure below invokes the active entry in the posted menu,
 261 # if there is one.  Otherwise it does nothing.
 262
 263 proc tk_invokeMenu {menu} {
 264     set i [$menu index active]
 265     if {$i != "none"} {
 266         tk_mbUnpost
 267         update idletasks
 268         $menu invoke $i
 269     }
 270 }
 271
 272 # The procedure below is invoked to keyboard-traverse to the first
 273 # menu for a given source window.  The source window is passed as
 274 # parameter.
 275
 276 proc tk_firstMenu w {
 277     set mb [lindex [tk_getMenuButtons $w] 0]
 278     if {$mb != ""} {
 279         tk_mbPost $mb
 280         [lindex [$mb config -menu] 4] activate 0
 281     }
 282 }
 283
 284 # The procedure below is invoked when a button-1-down event is
 285 # received by a menu button.  If the mouse is in the menu button
 286 # then it posts the button's menu.  If the mouse isn't in the
 287 # button's menu, then it deactivates any active entry in the menu.
 288 # Remember, event-sharing can cause this procedure to be invoked
 289 # for two different menu buttons on the same event.
 290
 291 proc tk_mbButtonDown w {
 292     global tk_priv
 293     if {[lindex [$w config -state] 4] == "disabled"} {
 294         return
 295     }
 296     if {$tk_priv(inMenuButton) == $w} {
 297         tk_mbPost $w
 298     }
 299     set menu [lindex [$tk_priv(posted) config -menu] 4]
 300     if {$tk_priv(window) != $menu} {
 301         $menu activate none
 302     }
 303 }