Return to menu.tcl CVS log

Up to [Micropolis - Activity] / micropolis / src / tk / library

Annotation of micropolis/src/tk/library/menu.tcl, revision 1.1

1.1     ! root        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: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.