home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tk3.3b1 / library / menu.tcl < prev    next >
Encoding:
Text File  |  1993-07-01  |  10.6 KB  |  350 lines
  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. # pulling down menus and menu traversal via the keyboard.
  6. #
  7. # $Header: /user6/ouster/wish/library/RCS/menu.tcl,v 1.19 93/07/01 13:42:01 ouster Exp $ SPRITE (Berkeley)
  8. #
  9. # Copyright (c) 1992-1993 The Regents of the University of California.
  10. # All rights reserved.
  11. #
  12. # Permission is hereby granted, without written agreement and without
  13. # license or royalty fees, to use, copy, modify, and distribute this
  14. # software and its documentation for any purpose, provided that the
  15. # above copyright notice and the following two paragraphs appear in
  16. # all copies of this software.
  17. #
  18. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  19. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  20. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  21. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  22. #
  23. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  24. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  25. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  26. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  27. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  28. #
  29.  
  30. # The procedure below is publically available.  It is used to identify
  31. # a frame that serves as a menu bar and the menu buttons that lie inside
  32. # the menu bar.  This procedure establishes proper "menu bar" behavior
  33. # for all of the menu buttons, including keyboard menu traversal.  Only
  34. # one menu bar may exist for a given top-level window at a time.
  35. # Arguments:
  36. #    
  37. # bar -                The path name of the containing frame.  Must
  38. #                be an ancestor of all of the menu buttons,
  39. #                since it will be be used in grabs.
  40. # additional arguments -    One or more menu buttons that are descendants
  41. #                of bar.  The order of these arguments
  42. #                determines the order of keyboard traversal.
  43. #                If no extra arguments are named then all of
  44. #                the menu bar information for bar is cancelled.
  45.  
  46. proc tk_menuBar {w args} {
  47.     global tk_priv
  48.     if {$args == ""} {
  49.     if [catch {set menus $tk_priv(menusFor$w)}] {
  50.         return ""
  51.     }
  52.     return $menus
  53.     }
  54.     if [info exists tk_priv(menusFor$w)] {
  55.     unset tk_priv(menusFor$w)
  56.     unset tk_priv(menuBarFor[winfo toplevel $w])
  57.     }
  58.     if {$args == "{}"} {
  59.     return
  60.     }
  61.     set tk_priv(menusFor$w) $args
  62.     set tk_priv(menuBarFor[winfo toplevel $w]) $w
  63.     bind $w <Any-ButtonRelease-1> tk_mbUnpost
  64. }
  65.  
  66. proc tk_menus {w args} {
  67.     error "tk_menus is obsolete in Tk versions 3.0 and later; please change your scripts to use tk_menuBar instead"
  68. }
  69.  
  70. # The procedure below is publically available.  It takes any number of
  71. # arguments that are names of widgets or classes.  It sets up bindings
  72. # for the widgets or classes so that keyboard menu traversal is possible
  73. # when the input focus is in those widgets or classes.
  74.  
  75. proc tk_bindForTraversal args {
  76.     foreach w $args {
  77.     bind $w <Alt-KeyPress> {tk_traverseToMenu %W %A}
  78.     bind $w <F10> {tk_firstMenu %W}
  79.     }
  80. }
  81.  
  82. # The procedure below does all of the work of posting a menu (including
  83. # unposting any other menu that might currently be posted).  The "w"
  84. # argument is the name of the menubutton for the menu to be posted.
  85. # Note:  if $w is disabled then the procedure does nothing.
  86.  
  87. proc tk_mbPost {w} {
  88.     global tk_priv tk_strictMotif
  89.     if {[lindex [$w config -state] 4] == "disabled"} {
  90.     return
  91.     }
  92.     if {$w == $tk_priv(posted)} {
  93.     grab -global $tk_priv(grab)
  94.     return
  95.     }
  96.     set menu [lindex [$w config -menu] 4]
  97.     if {$menu == ""} {
  98.     return
  99.     }
  100.     if ![string match $w* $menu] {
  101.     error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
  102.     }
  103.     set cur $tk_priv(posted)
  104.     if {$cur != ""} tk_mbUnpost
  105.     set tk_priv(relief) [lindex [$w config -relief] 4]
  106.     $w config -relief raised
  107.     set tk_priv(posted) $w
  108.     if {$tk_priv(focus) == ""} {
  109.     set tk_priv(focus) [focus]
  110.     }
  111.     set tk_priv(activeBg) [lindex [$menu config -activebackground] 4]
  112.     set tk_priv(activeFg) [lindex [$menu config -activeforeground] 4]
  113.     if $tk_strictMotif {
  114.     $menu config -activebackground [lindex [$menu config -background] 4]
  115.     $menu config -activeforeground [lindex [$menu config -foreground] 4]
  116.     }
  117.     $menu activate none
  118.     focus $menu
  119.     $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]]
  120.     if [catch {set grab $tk_priv(menuBarFor[winfo toplevel $w])}] {
  121.     set grab $w
  122.     } else {
  123.     if [lsearch $tk_priv(menusFor$grab) $w]<0 {
  124.         set grab $w
  125.     }
  126.     }
  127.     set tk_priv(cursor) [lindex [$grab config -cursor] 4]
  128.     $grab config -cursor arrow
  129.     set tk_priv(grab) $grab
  130.     grab -global $grab
  131. }
  132.  
  133. # The procedure below does all the work of unposting the menubutton that's
  134. # currently posted.  It takes no arguments.  Special notes:
  135. # 1. It's important to unpost the menu before releasing the grab, so
  136. #    that any Enter-Leave events (e.g. from menu back to main
  137. #    application) have mode NotifyGrab.
  138. # 2. Be sure to enclose various groups of commands in "catch" so that
  139. #    the procedure will complete even if the menubutton or the menu
  140. #    or the grab window has been deleted.
  141.  
  142. proc tk_mbUnpost {} {
  143.     global tk_priv
  144.     set w $tk_priv(posted)
  145.     if {$w != ""} {
  146.     catch {
  147.         set menu [lindex [$w config -menu] 4]
  148.         $menu unpost
  149.         $menu config -activebackground $tk_priv(activeBg)
  150.         $menu config -activeforeground $tk_priv(activeFg)
  151.         $w config -relief $tk_priv(relief)
  152.     }
  153.     catch {$tk_priv(grab) config -cursor $tk_priv(cursor)}
  154.     focus $tk_priv(focus)
  155.     grab release $tk_priv(grab)
  156.     set tk_priv(focus) ""
  157.     set tk_priv(posted) {}
  158.     }
  159. }
  160.  
  161. # The procedure below is invoked to implement keyboard traversal to
  162. # a menu button.  It takes two arguments:  the name of a window where
  163. # a keystroke originated, and the ascii character that was typed.
  164. # This procedure finds a menu bar by looking upward for a top-level
  165. # window, then looking for a window underneath that named "menu".
  166. # Then it searches through all the subwindows of "menu" for a menubutton
  167. # with an underlined character matching char.  If one is found, it
  168. # posts that menu.
  169.  
  170. proc tk_traverseToMenu {w char} {
  171.     global tk_priv
  172.     if {$char == ""} {
  173.     return
  174.     }
  175.     set char [string tolower $char]
  176.  
  177.     foreach mb [tk_getMenuButtons $w] {
  178.     if {[winfo class $mb] == "Menubutton"} {
  179.         set char2 [string index [lindex [$mb config -text] 4] \
  180.             [lindex [$mb config -underline] 4]]
  181.         if {[string compare $char [string tolower $char2]] == 0} {
  182.         tk_mbPost $mb
  183.         [lindex [$mb config -menu] 4] activate 0
  184.         return
  185.         }
  186.     }
  187.     }
  188. }
  189.  
  190. # The procedure below is used to implement keyboard traversal within
  191. # the posted menu.  It takes two arguments:  the name of the menu to
  192. # be traversed within, and an ASCII character.  It searches for an
  193. # entry in the menu that has that character underlined.  If such an
  194. # entry is found, it is invoked and the menu is unposted.
  195.  
  196. proc tk_traverseWithinMenu {w char} {
  197.     if {$char == ""} {
  198.     return
  199.     }
  200.     set char [string tolower $char]
  201.     set last [$w index last]
  202.     if {$last == "none"} {
  203.     return
  204.     }
  205.     for {set i 0} {$i <= $last} {incr i} {
  206.     if [catch {set char2 [string index \
  207.         [lindex [$w entryconfig $i -label] 4] \
  208.         [lindex [$w entryconfig $i -underline] 4]]}] {
  209.         continue
  210.     }
  211.     if {[string compare $char [string tolower $char2]] == 0} {
  212.         tk_mbUnpost
  213.         $w invoke $i
  214.         return
  215.     }
  216.     }
  217. }
  218.  
  219. # The procedure below takes a single argument, which is the name of
  220. # a window.  It returns a list containing path names for all of the
  221. # menu buttons associated with that window's top-level window, or an
  222. # empty list if there are none.
  223.  
  224. proc tk_getMenuButtons w {
  225.     global tk_priv
  226.     set top [winfo toplevel $w]
  227.     if [catch {set bar [set tk_priv(menuBarFor$top)]}] {
  228.     return ""
  229.     }
  230.     return $tk_priv(menusFor$bar)
  231. }
  232.  
  233. # The procedure below is used to traverse to the next or previous
  234. # menu in a menu bar.  It takes one argument, which is a count of
  235. # how many menu buttons forward or backward (if negative) to move.
  236. # If there is no posted menu then this procedure has no effect.
  237.  
  238. proc tk_nextMenu count {
  239.     global tk_priv
  240.     if {$tk_priv(posted) == ""} {
  241.     return
  242.     }
  243.     set buttons [tk_getMenuButtons $tk_priv(posted)]
  244.     set length [llength $buttons]
  245.     for {set i 0} 1 {incr i} {
  246.     if {$i >= $length} {
  247.         return
  248.     }
  249.     if {[lindex $buttons $i] == $tk_priv(posted)} {
  250.         break
  251.     }
  252.     }
  253.     incr i $count
  254.     while 1 {
  255.     while {$i < 0} {
  256.         incr i $length
  257.     }
  258.     while {$i >= $length} {
  259.         incr i -$length
  260.     }
  261.     set mb [lindex $buttons $i]
  262.     if {[lindex [$mb configure -state] 4] != "disabled"} {
  263.         break
  264.     }
  265.     incr i $count
  266.     }
  267.     tk_mbUnpost
  268.     tk_mbPost $mb
  269.     [lindex [$mb config -menu] 4] activate 0
  270. }
  271.  
  272. # The procedure below is used to traverse to the next or previous entry
  273. # in the posted menu.  It takes one argument, which is 1 to go to the
  274. # next entry or -1 to go to the previous entry.  Disabled entries are
  275. # skipped in this process.
  276.  
  277. proc tk_nextMenuEntry count {
  278.     global tk_priv
  279.     if {$tk_priv(posted) == ""} {
  280.     return
  281.     }
  282.     set menu [lindex [$tk_priv(posted) config -menu] 4]
  283.     if {[$menu index last] == "none"} {
  284.     return
  285.     }
  286.     set length [expr [$menu index last]+1]
  287.     set i [$menu index active]
  288.     if {$i == "none"} {
  289.     set i 0
  290.     } else {
  291.     incr i $count
  292.     }
  293.     while 1 {
  294.     while {$i < 0} {
  295.         incr i $length
  296.     }
  297.     while {$i >= $length} {
  298.         incr i -$length
  299.     }
  300.     if {[catch {$menu entryconfigure $i -state} state] == 0} {
  301.         if {[lindex $state 4] != "disabled"} {
  302.         break
  303.         }
  304.     }
  305.     incr i $count
  306.     }
  307.     $menu activate $i
  308. }
  309.  
  310. # The procedure below invokes the active entry in the posted menu,
  311. # if there is one.  Otherwise it does nothing.
  312.  
  313. proc tk_invokeMenu {menu} {
  314.     set i [$menu index active]
  315.     if {$i != "none"} {
  316.     tk_mbUnpost
  317.     update idletasks
  318.     $menu invoke $i
  319.     }
  320. }
  321.  
  322. # The procedure below is invoked to keyboard-traverse to the first
  323. # menu for a given source window.  The source window is passed as
  324. # parameter.
  325.  
  326. proc tk_firstMenu w {
  327.     set mb [lindex [tk_getMenuButtons $w] 0]
  328.     if {$mb != ""} {
  329.     tk_mbPost $mb
  330.     [lindex [$mb config -menu] 4] activate 0
  331.     }
  332. }
  333.  
  334. # The procedure below is invoked when a button-1-down event is
  335. # received by a menu button.  If the mouse is in the menu button
  336. # then it posts the button's menu.  If the mouse isn't in the
  337. # button's menu, then it deactivates any active entry in the menu.
  338. # Remember, event-sharing can cause this procedure to be invoked
  339. # for two different menu buttons on the same event.
  340.  
  341. proc tk_mbButtonDown w {
  342.     global tk_priv
  343.     if {[lindex [$w config -state] 4] == "disabled"} {
  344.     return
  345.     }
  346.     if {$tk_priv(inMenuButton) == $w} {
  347.     tk_mbPost $w
  348.     }
  349. }
  350.