Return to menu.tcl CVS log

Up to [Micropolis - Activity] / micropolis / res

Annotation of micropolis/res/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: # 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: 

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