git.zerfleddert.de Git - micropolis/blob - res/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 # Variables used by menu buttons:
  30 # $tk_priv(posted@$screen) -    keeps track of the menubutton whose menu is
  31 #                               currently posted (or empty string, if none).
  32 # $tk_priv(inMenuButton@$screen)-
  33 #                               if non-null, identifies menu button
  34 #                               containing mouse pointer.
  35 # $tk_priv(relief@$screen) -    keeps track of original relief of posted
  36 #                               menu button, so it can be restored later.
  37 # $tk_priv(dragging@$screen) -  if non-null, identifies menu button whose
  38 #                               menu is currently being dragged in a tear-off
  39 #                               operation.
  40 # $tk_priv(focus@$screen) -     records old focus window so focus can be
  41 #                               returned there after keyboard traversal
  42 #                               to menu.
  43 #
  44 # Variables used by menus:
  45 #     $tk_priv(x@$screen) and $tk_priv(y@$screen) are used to keep
  46 #     track of the position of the mouse cursor in the menu window
  47 #     during dragging of tear-off menus.  $tk_priv(window) keeps track
  48 #     of the menu containing the mouse, if any.
  49
  50 proc tk_menus {w args} {
  51     global tk_priv
  52
  53     if {$args == ""} {
  54         if [catch {set result [set tk_priv(menusFor$w)]}] {
  55             return ""
  56         }
  57         return $result
  58     }
  59
  60     if {$args == "{}"} {
  61         catch {unset tk_priv(menusFor$w)}
  62         return ""
  63     }
  64
  65     append tk_priv(menusFor$w) " $args"
  66 }
  67
  68 # The procedure below is publically available.  It takes any number of
  69 # arguments taht are names of widgets or classes.  It sets up bindings
  70 # for the widgets or classes so that keyboard menu traversal is possible
  71 # when the input focus is in those widgets or classes.
  72
  73 proc tk_bindForTraversal args {
  74     foreach w $args {
  75         bind $w <Alt-KeyPress> {tk_traverseToMenu %W %A}
  76         bind $w <F10> {tk_firstMenu %W}
  77     }
  78 }
  79
  80 # The procedure below does all of the work of posting a menu (including
  81 # unposting any other menu that might currently be posted).  The "w"
  82 # argument is the name of the menubutton for the menu to be posted.
  83 # Note:  if $w is disabled then the procedure does nothing.
  84
  85 proc tk_mbPost {w} {
  86     global tk_priv
  87     if {[lindex [$w config -state] 4] == "disabled"} {
  88         return
  89     }
  90     set screen [winfo screen $w]
  91     if {![info exists tk_priv(posted@$screen)]} {
  92         set tk_priv(posted@$screen) {}
  93     }
  94     if {![info exists tk_priv(focus@$screen)]} {
  95         set tk_priv(focus@$screen) {}
  96     }
  97     set cur $tk_priv(posted@$screen)
  98     if {$cur == $w} {
  99         return
 100     }
 101     if {$cur != ""} {tk_mbUnpost $w}
 102     set tk_priv(relief@$screen) [lindex [$w config -relief] 4]
 103     $w config -relief raised
 104     set tk_priv(cursor@$screen) [lindex [$w config -cursor] 4]
 105     $w config -cursor arrow
 106     $w post
 107     catch {grab -global $w}
 108     set tk_priv(posted@$screen) $w
 109     if {$tk_priv(focus@$screen) == ""} {
 110         set tk_priv(focus@$screen) [focus -query $w]
 111     }
 112     set menu [lindex [$w config -menu] 4]
 113     focus $menu
 114 }
 115
 116 # The procedure below does all the work of unposting the menubutton that's
 117 # currently posted.  It takes no arguments.
 118
 119 proc tk_mbUnpost {w} {
 120     global tk_priv
 121     set screen [winfo screen $w]
 122     if {![info exists tk_priv(posted@$screen)]} {
 123         set tk_priv(posted@$screen) {}
 124     }
 125     if {![info exists tk_priv(focus@$screen)]} {
 126         set tk_priv(focus@$screen) {}
 127     }
 128     set mb $tk_priv(posted@$screen)
 129     if {$mb != ""} {
 130         $mb config -relief $tk_priv(relief@$screen)
 131         $mb config -cursor $tk_priv(cursor@$screen)
 132         $mb unpost
 133         catch {grab -off $mb}
 134         set menu [lindex [$mb config -menu] 4]
 135         focus $tk_priv(focus@$screen)
 136         set tk_priv(focus@$screen) ""
 137         set tk_priv(posted@$screen) {}
 138     }
 139 }
 140
 141 # The procedure below is invoked to implement keyboard traversal to
 142 # a menu button.  It takes two arguments:  the name of a window where
 143 # a keystroke originated, and the ascii character that was typed.
 144 # This procedure finds a menu bar by looking upward for a top-level
 145 # window, then looking for a window underneath that named "menu".
 146 # Then it searches through all the subwindows of "menu" for a menubutton
 147 # with an underlined character matching char.  If one is found, it
 148 # posts that menu.
 149
 150 proc tk_traverseToMenu {w char} {
 151     if {$char == ""} {
 152         return
 153     }
 154     set char [string tolower $char]
 155
 156     foreach mb [tk_getMenuButtons $w] {
 157         if {[winfo class $mb] == "Menubutton"} {
 158             set char2 [string index [lindex [$mb config -text] 4] \
 159                     [lindex [$mb config -underline] 4]]
 160             if {[string compare $char [string tolower $char2]] == 0} {
 161                 tk_mbPost $mb
 162                 [lindex [$mb config -menu] 4] activate 0
 163                 return
 164             }
 165         }
 166     }
 167 }
 168
 169 # The procedure below is used to implement keyboard traversal within
 170 # the posted menu.  It takes two arguments:  the name of the menu to
 171 # be traversed within, and an ASCII character.  It searches for an
 172 # entry in the menu that has that character underlined.  If such an
 173 # entry is found, it is invoked and the menu is unposted.
 174
 175 proc tk_traverseWithinMenu {w char} {
 176     if {$char == ""} {
 177         return
 178     }
 179     set char [string tolower $char]
 180     set last [$w index last]
 181     for {set i 0} {$i <= $last} {incr i} {
 182         if [catch {set char2 [string index \
 183                 [lindex [$w entryconfig $i -label] 4] \
 184                 [lindex [$w entryconfig $i -underline] 4]]}] {
 185             continue
 186         }
 187         if {[string compare $char [string tolower $char2]] == 0} {
 188             tk_mbUnpost $w
 189             $w invoke $i
 190             return
 191         }
 192     }
 193 }
 194
 195 # The procedure below takes a single argument, which is the name of
 196 # a window.  It returns a list containing path names for all of the
 197 # menu buttons associated with that window's top-level window, or an
 198 # empty list if there are none.
 199
 200 proc tk_getMenuButtons {w} {
 201     global tk_priv
 202     set top [winfo toplevel $w]
 203     if [catch {set buttons [set tk_priv(menusFor$top)]}] {
 204         return ""
 205     }
 206     return $buttons
 207 }
 208
 209 # The procedure below is used to traverse to the next or previous
 210 # menu in a menu bar.  It takes one argument, which is a count of
 211 # how many menu buttons forward or backward (if negative) to move.
 212 # If there is no posted menu then this procedure has no effect.
 213
 214 proc tk_nextMenu {w count} {
 215     global tk_priv
 216     set screen [winfo screen $w]
 217     if {![info exists tk_priv(posted@$screen)]} {
 218         set tk_priv(posted@$screen) {}
 219     }
 220     if {$tk_priv(posted@$screen) == ""} {
 221         return
 222     }
 223     set buttons [tk_getMenuButtons $tk_priv(posted@$screen)]
 224     set length [llength $buttons]
 225     for {set i 0} 1 {incr i} {
 226         if {$i >= $length} {
 227             return
 228         }
 229         if {[lindex $buttons $i] == $tk_priv(posted@$screen)} {
 230             break
 231         }
 232     }
 233     incr i $count
 234     while 1 {
 235         while {$i < 0} {
 236             incr i $length
 237         }
 238         while {$i >= $length} {
 239             incr i -$length
 240         }
 241         set mb [lindex $buttons $i]
 242         if {[lindex [$mb configure -state] 4] != "disabled"} {
 243             break
 244         }
 245         incr i $count
 246     }
 247     tk_mbUnpost $w
 248     tk_mbPost $mb
 249     [lindex [$mb config -menu] 4] activate 0
 250 }
 251
 252 # The procedure below is used to traverse to the next or previous entry
 253 # in the posted menu.  It takes one argument, which is 1 to go to the
 254 # next entry or -1 to go to the previous entry.  Disabled entries are
 255 # skipped in this process.
 256
 257 proc tk_nextMenuEntry {w count} {
 258     global tk_priv
 259     set screen [winfo screen $w]
 260     if {![info exists tk_priv(posted@$screen)]} {
 261         set tk_priv(posted@$screen) {}
 262     }
 263     if {$tk_priv(posted@$screen) == ""} {
 264         return
 265     }
 266     set menu [lindex [$tk_priv(posted@$screen) config -menu] 4]
 267     set length [expr [$menu index last]+1]
 268     set i [$menu index active]
 269     if {$i == "none"} {
 270         set i 0
 271     } else {
 272         incr i $count
 273     }
 274     while 1 {
 275         while {$i < 0} {
 276             incr i $length
 277         }
 278         while {$i >= $length} {
 279             incr i -$length
 280         }
 281         if {[catch {$menu entryconfigure $i -state} state] == 0} {
 282             if {[lindex $state 4] != "disabled"} {
 283                 break
 284             }
 285         }
 286         incr i $count
 287     }
 288     $menu activate $i
 289 }
 290
 291 # The procedure below invokes the active entry in the posted menu,
 292 # if there is one.  Otherwise it does nothing.
 293
 294 proc tk_invokeMenu {w} {
 295     set i [$w index active]
 296     if {$i != "none"} {
 297         tk_mbUnpost $w
 298         update idletasks
 299         $w invoke $i
 300     }
 301 }
 302
 303 # The procedure below is invoked to keyboard-traverse to the first
 304 # menu for a given source window.  The source window is passed as
 305 # parameter.
 306
 307 proc tk_firstMenu {w} {
 308     set mb [lindex [tk_getMenuButtons $w] 0]
 309     if {$mb != ""} {
 310         tk_mbPost $mb
 311         [lindex [$mb config -menu] 4] activate 0
 312     }
 313 }
 314
 315 # The procedure below is invoked when a button-1-down event is
 316 # received by a menu button.  If the mouse is in the menu button
 317 # then it posts the button's menu.  If the mouse isn't in the
 318 # button's menu, then it deactivates any active entry in the menu.
 319 # Remember, event-sharing can cause this procedure to be invoked
 320 # for two different menu buttons on the same event.
 321
 322 proc tk_mbButtonDown {w x y} {
 323     global tk_priv
 324     set screen [winfo screen $w]
 325     if {![info exists tk_priv(inMenuButton@$screen)]} {
 326         set tk_priv(inMenuButton@$screen) {}
 327     }
 328     if {![info exists tk_priv(posted@$screen)]} {
 329         set tk_priv(posted@$screen) {}
 330     }
 331     if {[lindex [$w config -state] 4] == "disabled"} {
 332         return
 333     }
 334     if {$tk_priv(inMenuButton@$screen) == $w} {
 335         tk_mbPost $w
 336     }
 337     if {$tk_priv(posted@$screen) != ""} then {
 338         set menu [lindex [$tk_priv(posted@$screen) config -menu] 4]
 339         if {![info exists tk_priv(window@$screen)]} {
 340             set tk_priv(window@$screen) {}
 341         }
 342         if {$tk_priv(window@$screen) != $menu} {
 343             $menu activate none
 344         }
 345     }
 346 }
 347
 348 proc tk_mbButtonUp {w x y} {
 349     global tk_priv
 350     set screen [winfo screen $w]
 351     if {![info exists tk_priv(inMenuButton@$screen)]} {
 352         set tk_priv(inMenuButton@$screen) {}
 353     }
 354     if {![info exists tk_priv(posted@$screen)]} {
 355         set tk_priv(posted@$screen) {}
 356     }
 357     if {($tk_priv(inMenuButton@$screen) != "") &&
 358         ($tk_priv(posted@$screen) != "")} {
 359         [lindex [$tk_priv(posted@$screen) config -menu] 4] activate 0
 360     } else {
 361         tk_mbUnpost $w
 362     }
 363 }
 364
 365 proc tk_mbButtonEnter {w m} {
 366     global tk_priv
 367     set screen [winfo screen $w]
 368     set tk_priv(inMenuButton@$screen) $w
 369     if {[lindex [$w config -state] 4] != "disabled"} {
 370         $w config -state active
 371     }
 372 }
 373
 374 proc tk_mbButtonLeave {w} {
 375     global tk_priv
 376     set screen [winfo screen $w]
 377     set tk_priv(inMenuButton@$screen) {}
 378     if {[lindex [$w config -state] 4] != "disabled"} {
 379         $w config -state normal
 380     }
 381 }
 382
 383 # In the binding below, it's important to ignore grab-related entries
 384 # and exits because they lag reality and can cause menus to chase
 385 # their own tail, repeatedly posting and unposting.
 386
 387 proc tk_mbButton1Enter {w m} {
 388     global tk_priv
 389     set screen [winfo screen $w]
 390     set tk_priv(inMenuButton@$screen) $w
 391     if {([lindex [$w config -state] 4] != "disabled")
 392             && ("$m" != "NotifyGrab") && ("$m" != "NotifyUngrab")} {
 393         $w config -state active
 394         tk_mbPost $w
 395     }
 396 }
 397
 398
 399 proc tk_mbButton2Down {w x y} {
 400     global tk_priv
 401     set screen [winfo screen $w]
 402     if {![info exists tk_priv(inMenuButton@$screen)]} {
 403         set tk_priv(inMenuButton@$screen) {}
 404     }
 405     if {![info exists tk_priv(posted@$screen)]} {
 406         set tk_priv(posted@$screen) {}
 407     }
 408     if {($tk_priv(posted@$screen) == "")
 409             && ([lindex [$w config -state] 4] != "disabled")} {
 410         set tk_priv(dragging@$screen) $w
 411         [lindex [$w config -menu] 4] post $x $y
 412     }
 413 }
 414
 415
 416 proc tk_mbButton2Motion {w x y} {
 417     global tk_priv
 418     set screen [winfo screen $w]
 419     if {![info exists tk_priv(dragging@$screen)]} {
 420         set tk_priv(dragging@$screen) {}
 421     }
 422     if {$tk_priv(dragging@$screen) != ""} {
 423         [lindex [$tk_priv(dragging@$screen) config -menu] 4] post $x $y
 424     }
 425 }
 426
 427 proc tk_mbButton2Up {w x y} {
 428     global tk_priv
 429     set screen [winfo screen $w]
 430     set tk_priv(dragging@$screen) ""
 431 }
 432
 433
 434 proc tk_menuEnter {w y} {
 435     global tk_priv
 436     set screen [winfo screen $w]
 437     set tk_priv(window@$screen) $w
 438     $w activate @$y
 439 }
 440
 441 proc tk_menuLeave {w} {
 442     global tk_priv
 443     set screen [winfo screen $w]
 444     set tk_priv(window@$screen) {}
 445     $w activate none
 446 }
 447
 448 proc tk_menuMotion {w y} {
 449     global tk_priv
 450     set screen [winfo screen $w]
 451     if {![info exists tk_priv(window@$screen)]} {
 452         set tk_priv(window@$screen) {}
 453     }
 454     if {$tk_priv(window@$screen) != ""} {
 455         $w activate @$y
 456     }
 457 }
 458
 459 proc tk_menuUp {w y} {
 460     tk_menuMotion $w $y
 461     tk_invokeMenu $w
 462 }
 463
 464 proc tk_menu2Down {w x y} {
 465     global tk_priv
 466     set screen [winfo screen $w]
 467     set tk_priv(x@$screen) $x
 468     set tk_priv(y@$screen) $y
 469 }
 470
 471 proc tk_menu2Motion {w x y} {
 472     global tk_priv
 473     set screen [winfo screen $w]
 474     if {$tk_priv(posted@$screen) == ""} {
 475         $w post [expr $x-$tk_priv(x@$screen)] [expr $y-$tk_priv(y@$screen)]
 476     }
 477 }
 478