| # |
| # Menubar widget |
| # ---------------------------------------------------------------------- |
| # The Menubar command creates a new window (given by the pathName |
| # argument) and makes it into a Pull down menu widget. Additional |
| # options, described above may be specified on the command line or |
| # in the option database to configure aspects of the Menubar such |
| # as its colors and font. The Menubar command returns its pathName |
| # argument. At the time this command is invoked, there must not exist |
| # a window named pathName, but pathName's parent must exist. |
| # |
| # A Menubar is a widget that simplifies the task of creating |
| # menu hierarchies. It encapsulates a frame widget, as well |
| # as menubuttons, menus, and menu entries. The Menubar allows |
| # menus to be specified and refer enced in a more consistent |
| # manner than using Tk to build menus directly. First, Menubar |
| # allows a menu tree to be expressed in a hierachical "language". |
| # The Menubar accepts a menuButtons option that allows a list of |
| # menubuttons to be added to the Menubar. In turn, each menubutton |
| # accepts a menu option that spec ifies a list of menu entries |
| # to be added to the menubutton's menu (as well as an option |
| # set for the menu). Cascade entries in turn, accept a menu |
| # option that specifies a list of menu entries to be added to |
| # the cascade's menu (as well as an option set for the menu). In |
| # this manner, a complete menu grammar can be expressed to the |
| # Menubar. Additionally, the Menubar allows each component of |
| # the Menubar system to be referenced by a simple componentPathName |
| # syntax. Finally, the Menubar extends the option set of menu |
| # entries to include the helpStr option used to implement status |
| # bar help. |
| # |
| # WISH LIST: |
| # This section lists possible future enhancements. |
| # |
| # ---------------------------------------------------------------------- |
| # AUTHOR: Bill W. Scott |
| # |
| # CURRENT MAINTAINER: Chad Smith --> csmith@adc.com or itclguy@yahoo.com |
| # |
| # @(#) $Id: menubar.itk,v 1.8 2001/08/15 18:33:13 smithc Exp $ |
| # ---------------------------------------------------------------------- |
| # Copyright (c) 1995 DSC Technologies Corporation |
| # ====================================================================== |
| # Permission to use, copy, modify, distribute and license this software |
| # and its documentation for any purpose, and without fee or written |
| # agreement with DSC, is hereby granted, provided that the above copyright |
| # notice appears in all copies and that both the copyright notice and |
| # warranty disclaimer below appear in supporting documentation, and that |
| # the names of DSC Technologies Corporation or DSC Communications |
| # Corporation not be used in advertising or publicity pertaining to the |
| # software without specific, written prior permission. |
| # |
| # DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
| # ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, AND NON- |
| # INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE |
| # AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, |
| # SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. IN NO EVENT SHALL |
| # DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
| # ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
| # WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, |
| # ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
| # SOFTWARE. |
| # ====================================================================== |
| |
| |
| # |
| # Usual options. |
| # |
| itk::usual Menubar { |
| keep -activebackground -activeborderwidth -activeforeground \ |
| -anchor -background -borderwidth -cursor -disabledforeground \ |
| -font -foreground -highlightbackground -highlightthickness \ |
| -highlightcolor -justify -padx -pady -wraplength |
| } |
| |
| itcl::class iwidgets::Menubar { |
| inherit itk::Widget |
| |
| constructor { args } {} |
| |
| itk_option define -foreground foreground Foreground Black |
| itk_option define -activebackground activeBackground Foreground "#ececec" |
| itk_option define -activeborderwidth activeBorderWidth BorderWidth 2 |
| itk_option define -activeforeground activeForeground Background black |
| itk_option define -anchor anchor Anchor center |
| itk_option define -borderwidth borderWidth BorderWidth 2 |
| itk_option define \ |
| -disabledforeground disabledForeground DisabledForeground #a3a3a3 |
| itk_option define \ |
| -font font Font "-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*" |
| itk_option define \ |
| -highlightbackground highlightBackground HighlightBackground #d9d9d9 |
| itk_option define -highlightcolor highlightColor HighlightColor Black |
| itk_option define \ |
| -highlightthickness highlightThickness HighlightThickness 0 |
| itk_option define -justify justify Justify center |
| itk_option define -padx padX Pad 4p |
| itk_option define -pady padY Pad 3p |
| itk_option define -wraplength wrapLength WrapLength 0 |
| itk_option define -menubuttons menuButtons MenuButtons {} |
| itk_option define -helpvariable helpVariable HelpVariable {} |
| |
| public { |
| method add { type path args } { } |
| method delete { args } { } |
| method index { path } { } |
| method insert { beforeComponent type name args } |
| method invoke { entryPath } { } |
| method menucget { args } { } |
| method menuconfigure { path args } { } |
| method path { args } { } |
| method type { path } { } |
| method yposition { entryPath } { } |
| } |
| |
| private { |
| method menubutton { menuName args } { } |
| method options { args } { } |
| method command { cmdName args } { } |
| method checkbutton { chkName args } { } |
| method radiobutton { radName args } { } |
| method separator { sepName args } { } |
| method cascade { casName args } { } |
| method _helpHandler { menuPath } { } |
| method _addMenuButton { buttonName args} { } |
| method _insertMenuButton { beforeMenuPath buttonName args} { } |
| method _makeMenuButton {buttonName args} { } |
| method _makeMenu \ |
| { componentName widgetName menuPath menuEvalStr } { } |
| method _substEvalStr { evalStr } { } |
| method _deleteMenu { menuPath {menuPath2 {}} } { } |
| method _deleteAMenu { path } { } |
| method _addEntry { type path args } { } |
| method _addCascade { tkMenuPath path args } { } |
| method _insertEntry { beforeEntryPath type name args } { } |
| method _insertCascade { bfIndex tkMenuPath path args } { } |
| method _deleteEntry { entryPath {entryPath2 {}} } { } |
| method _configureMenu { path tkPath {option {}} args } { } |
| method _configureMenuOption { type path args } { } |
| method _configureMenuEntry { path index {option {}} args } { } |
| method _unsetPaths { parent } { } |
| method _entryPathToTkMenuPath {entryPath} { } |
| method _getTkIndex { tkMenuPath tkIndex} { } |
| method _getPdIndex { tkMenuPath tkIndex } { } |
| method _getMenuList { } { } |
| method _getEntryList { menu } { } |
| method _parsePath { path } { } |
| method _getSymbolicPath { parent segment } { } |
| method _getCallerLevel { } |
| |
| variable _parseLevel 0 ;# The parse level depth |
| variable _callerLevel #0 ;# abs level of caller |
| variable _pathMap ;# Array indexed by Menubar's path |
| ;# naming, yields tk menu path |
| variable _entryIndex -1 ;# current entry help is displayed |
| ;# for during help <motion> events |
| |
| variable _tkMenuPath ;# last tk menu being added to |
| variable _ourMenuPath ;# our last valid path constructed. |
| |
| variable _menuOption ;# The -menu option |
| variable _helpString ;# The -helpstr optio |
| } |
| } |
| |
| # |
| # Use option database to override default resources. |
| # |
| option add *Menubar*Menu*tearOff false widgetDefault |
| option add *Menubar*Menubutton*relief flat widgetDefault |
| option add *Menubar*Menu*relief raised widgetDefault |
| |
| # |
| # Provide a lowercase access method for the menubar class |
| # |
| proc ::iwidgets::menubar { args } { |
| uplevel ::iwidgets::Menubar $args |
| } |
| |
| # ------------------------------------------------------------------ |
| # CONSTRUCTOR |
| # ------------------------------------------------------------------ |
| itcl::body iwidgets::Menubar::constructor { args } { |
| component hull configure -borderwidth 0 |
| |
| # |
| # Create the Menubar Frame that will hold the menus. |
| # |
| # might want to make -relief and -bd options with defaults |
| itk_component add menubar { |
| frame $itk_interior.menubar -relief raised -bd 2 |
| } { |
| keep -cursor -background -width -height |
| } |
| pack $itk_component(menubar) -fill both -expand yes |
| |
| # Map our pathname to class to the actual menubar frame |
| set _pathMap(.) $itk_component(menubar) |
| |
| eval itk_initialize $args |
| |
| # |
| # HACK HACK HACK |
| # Tk expects some variables to be defined and due to some |
| # unknown reason we confuse its normal ordering. So, if |
| # the user creates a menubutton with no menu it will fail |
| # when clicked on with a "Error: can't read $tkPriv(oldGrab): |
| # no such element in array". So by setting it to null we |
| # avoid this error. |
| uplevel #0 "set tkPriv(oldGrab) {}" |
| |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTIONS |
| # ------------------------------------------------------------------ |
| # This first set of options are for configuring menus and/or menubuttons |
| # at the menu level. |
| # |
| # ------------------------------------------------------------------ |
| # OPTION -foreground |
| # |
| # menu |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::foreground { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -activebackground |
| # |
| # menu |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::activebackground { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -activeborderwidth |
| # |
| # menu |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::activeborderwidth { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -activeforeground |
| # |
| # menu |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::activeforeground { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -anchor |
| # |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::anchor { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -borderwidth |
| # |
| # menu |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::borderwidth { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -disabledforeground |
| # |
| # menu |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::disabledforeground { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -font |
| # |
| # menu |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::font { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -highlightbackground |
| # |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::highlightbackground { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -highlightcolor |
| # |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::highlightcolor { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -highlightthickness |
| # |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::highlightthickness { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -justify |
| # |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::justify { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -padx |
| # |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::padx { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -pady |
| # |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::pady { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -wraplength |
| # |
| # menubutton |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::wraplength { |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -menubuttons |
| # |
| # The menuButton option is a string which specifies the arrangement |
| # of menubuttons on the Menubar frame. Each menubutton entry is |
| # delimited by the newline character. Each entry is treated as |
| # an add command to the Menubar. |
| # |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::menubuttons { |
| if { $itk_option(-menubuttons) != {} } { |
| |
| # IF one exists already, delete the old one and create |
| # a new one |
| if { ! [catch {_parsePath .0}] } { |
| delete .0 .last |
| } |
| |
| # |
| # Determine the context level to evaluate the option string at |
| # |
| set _callerLevel [_getCallerLevel] |
| |
| # |
| # Parse the option string in their scope, then execute it in |
| # our scope. |
| # |
| incr _parseLevel |
| _substEvalStr itk_option(-menubuttons) |
| eval $itk_option(-menubuttons) |
| |
| # reset so that we know we aren't parsing in a scope currently. |
| incr _parseLevel -1 |
| } |
| } |
| |
| # ------------------------------------------------------------------ |
| # OPTION -helpvariable |
| # |
| # Specifies the global variable to update whenever the mouse is in |
| # motion over a menu entry. This global variable is updated with the |
| # current value of the active menu entry's helpStr. Other widgets |
| # can "watch" this variable with the trace command, or as is the |
| # case with entry or label widgets, they can set their textVariable |
| # to the same global variable. This allows for a simple implementation |
| # of a help status bar. Whenever the mouse leaves a menu entry, |
| # the helpVariable is set to the empty string {}. |
| # ------------------------------------------------------------------ |
| itcl::configbody iwidgets::Menubar::helpvariable { |
| if {"" != $itk_option(-helpvariable) && |
| ![string match ::* $itk_option(-helpvariable)] && |
| ![string match @itcl* $itk_option(-helpvariable)]} { |
| set itk_option(-helpvariable) "::$itk_option(-helpvariable)" |
| } |
| } |
| |
| |
| # ------------------------------------------------------------- |
| # |
| # METHOD: add type path args |
| # |
| # Adds either a menu to the menu bar or a menu entry to a |
| # menu pane. |
| # |
| # If the type is one of cascade, checkbutton, command, |
| # radiobutton, or separator it adds a new entry to the bottom |
| # of the menu denoted by the menuPath prefix of componentPath- |
| # Name. The new entry's type is given by type. If additional |
| # arguments are present, they specify options available to |
| # component type Entry. See the man pages for menu(n) in the |
| # section on Entries. In addition all entries accept an added |
| # option, helpStr: |
| # |
| # -helpstr value |
| # |
| # Specifes the string to associate with the entry. |
| # When the mouse moves over the associated entry, the variable |
| # denoted by helpVariable is set. Another widget can bind to |
| # the helpVariable and thus display status help. |
| # |
| # If the type is menubutton, it adds a new menubut- |
| # ton to the menu bar. If additional arguments are present, |
| # they specify options available to component type MenuButton. |
| # |
| # If the type is menubutton or cascade, the menu |
| # option is available in addition to normal Tk options for |
| # these to types. |
| # |
| # -menu menuSpec |
| # |
| # This is only valid for componentPathNames of type |
| # menubutton or cascade. Specifes an option set and/or a set |
| # of entries to place on a menu and associate with the menu- |
| # button or cascade. The option keyword allows the menu widget |
| # to be configured. Each item in the menuSpec is treated as |
| # add commands (each with the possibility of having other |
| # -menu options). In this way a menu can be recursively built. |
| # |
| # The last segment of componentPathName cannot be |
| # one of the keywords last, menu, end. Additionally, it may |
| # not be a number. However the componentPathName may be refer- |
| # enced in this manner (see discussion of Component Path |
| # Names). |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::add { type path args } { |
| if ![regexp \ |
| {^(menubutton|command|cascade|separator|radiobutton|checkbutton)$} \ |
| $type] { |
| error "bad type \"$type\": must be one of the following:\ |
| \"command\", \"checkbutton\", \"radiobutton\",\ |
| \"separator\", \"cascade\", or \"menubutton\"" |
| } |
| regexp {[^.]+$} $path segName |
| if [regexp {^(menu|last|end|[0-9]+)$} $segName] { |
| error "bad name \"$segName\": user created component \ |
| path names may not end with \ |
| \"end\", \"last\", \"menu\", \ |
| or be an integer" |
| } |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # OK, either add a menu |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| if { $type == "menubutton" } { |
| # grab the last component name (the menu name) |
| eval _addMenuButton $segName $args |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Or add an entry |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| } else { |
| eval _addEntry $type $path $args |
| } |
| } |
| |
| |
| # ------------------------------------------------------------- |
| # |
| # METHOD: delete entryPath ?entryPath2? |
| # |
| # If componentPathName is of component type MenuButton or |
| # Menu, delete operates on menus. If componentPathName is of |
| # component type Entry, delete operates on menu entries. |
| # |
| # This command deletes all components between com- |
| # ponentPathName and componentPathName2 inclusive. If com- |
| # ponentPathName2 is omitted then it defaults to com- |
| # ponentPathName. Returns an empty string. |
| # |
| # If componentPathName is of type Menubar, then all menus |
| # and the menu bar frame will be destroyed. In this case com- |
| # ponentPathName2 is ignored. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::delete { args } { |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Handle out of bounds in arg lengths |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| if { [llength $args] > 0 && [llength $args] <=2 } { |
| |
| # Path Conversions |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| set path [_parsePath [lindex $args 0]] |
| |
| set pathOrIndex $_pathMap($path) |
| |
| # Menu Entry |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| if { [regexp {^[0-9]+$} $pathOrIndex] } { |
| eval "_deleteEntry $args" |
| |
| # Menu |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| } else { |
| eval "_deleteMenu $args" |
| } |
| } else { |
| error "wrong # args: should be \ |
| \"$itk_component(hull) delete pathName ?pathName2?\"" |
| } |
| return "" |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # METHOD: index path |
| # |
| # If componentPathName is of type menubutton or menu, it |
| # returns the position of the menu/menubutton on the Menubar |
| # frame. |
| # |
| # If componentPathName is of type command, separator, |
| # radiobutton, checkbutton, or cascade, it returns the menu |
| # widget's numerical index for the entry corresponding to com- |
| # ponentPathName. If path is not found or the Menubar frame is |
| # passed in, -1 is returned. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::index { path } { |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Path conversions |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| if { [catch {set fullPath [_parsePath $path]} ] } { |
| return -1 |
| } |
| if { [catch {set tkPathOrIndex $_pathMap($fullPath)} ] } { |
| return -1 |
| } |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # If integer, return the value, otherwise look up the menu position |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| if { [regexp {^[0-9]+$} $tkPathOrIndex] } { |
| set index $tkPathOrIndex |
| } else { |
| set index [lsearch [_getMenuList] $fullPath] |
| } |
| |
| return $index |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # METHOD: insert beforeComponent type name ?option value? |
| # |
| # Insert a new component named name before the component |
| # specified by componentPathName. |
| # |
| # If componentPathName is of type MenuButton or Menu, the |
| # new component inserted is of type Menu and given the name |
| # name. In this case valid option value pairs are those |
| # accepted by menubuttons. |
| # |
| # If componentPathName is of type Entry, the new com- |
| # ponent inserted is of type Entry and given the name name. In |
| # this case valid option value pairs are those accepted by |
| # menu entries. |
| # |
| # name cannot be one of the keywords last, menu, end. |
| # dditionally, it may not be a number. However the com- |
| # ponentPathName may be referenced in this manner (see discus- |
| # sion of Component Path Names). |
| # |
| # Returns -1 if the menubar frame is passed in. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::insert { beforeComponent type name args } { |
| if ![regexp \ |
| {^(menubutton|command|cascade|separator|radiobutton|checkbutton)$} \ |
| $type] { |
| error "bad type \"$type\": must be one of the following:\ |
| \"command\", \"checkbutton\", \"radiobutton\",\ |
| \"separator\", \"cascade\", or \"menubutton\"" |
| } |
| regexp {[^.]+$} $name segName |
| if [regexp {^(menu|last|end|[0-9]+)$} $segName] { |
| error "bad name \"$name\": user created component \ |
| path names may not end with \ |
| \"end\", \"last\", \"menu\", \ |
| or be an integer" |
| } |
| |
| set beforeComponent [_parsePath $beforeComponent] |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Choose menu insertion or entry insertion |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| if { $type == "menubutton" } { |
| eval _insertMenuButton $beforeComponent $name $args |
| } else { |
| eval _insertEntry $beforeComponent $type $name $args |
| } |
| } |
| |
| |
| # ------------------------------------------------------------- |
| # |
| # METHOD: invoke entryPath |
| # |
| # Invoke the action of the menu entry denoted by |
| # entryComponentPathName. See the sections on the individual |
| # entries in the menu(n) man pages. If the menu entry is dis- |
| # abled then nothing happens. If the entry has a command |
| # associated with it then the result of that command is |
| # returned as the result of the invoke widget command. Other- |
| # wise the result is an empty string. |
| # |
| # If componentPathName is not a menu entry, an error is |
| # issued. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::invoke { entryPath } { |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Path Conversions |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| set entryPath [_parsePath $entryPath] |
| set index $_pathMap($entryPath) |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Error Processing |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| # first verify that beforeEntryPath is actually a path to |
| # an entry and not to menu, menubutton, etc. |
| if { ! [regexp {^[0-9]+$} $index] } { |
| error "bad entry path: beforeEntryPath is not an entry" |
| } |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Call invoke command |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| # get the tk menu path to call |
| set tkMenuPath [_entryPathToTkMenuPath $entryPath] |
| |
| # call the menu's invoke command, adjusting index based on tearoff |
| $tkMenuPath invoke [_getTkIndex $tkMenuPath $index] |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # METHOD: menucget componentPath option |
| # |
| # Returns the current value of the configuration option |
| # given by option. The component type of componentPathName |
| # determines the valid available options. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::menucget { path opt } { |
| return [lindex [menuconfigure $path $opt] 4] |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # METHOD: menuconfigure componentPath ?option? ?value option value...? |
| # |
| # Query or modify the configuration options of the sub- |
| # component of the Menubar specified by componentPathName. If |
| # no option is specified, returns a list describing all of the |
| # available options for componentPathName (see |
| # Tk_ConfigureInfo for information on the format of this |
| # list). If option is specified with no value, then the com- |
| # mand returns a list describing the one named option (this |
| # list will be identical to the corresponding sublist of the |
| # value returned if no option is specified). If one or more |
| # option-value pairs are specified, then the command modifies |
| # the given widget option(s) to have the given value(s); in |
| # this case the command returns an empty string. The component |
| # type of componentPathName determines the valid available |
| # options. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::menuconfigure { path args } { |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Path Conversions |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| set path [_parsePath $path] |
| set tkPathOrIndex $_pathMap($path) |
| |
| # Case: Menu entry being configured |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| if { [regexp {^[0-9]+$} $tkPathOrIndex] } { |
| eval "_configureMenuEntry $path $tkPathOrIndex $args" |
| |
| # Case: Menu (button and pane) being configured. |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| } else { |
| eval _configureMenu $path $tkPathOrIndex $args |
| } |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # METHOD: path |
| # |
| # SYNOPIS: path ?<mode>? <pattern> |
| # |
| # Returns a fully formed component path that matches pat- |
| # tern. If no match is found it returns -1. The mode argument |
| # indicates how the search is to be matched against pattern |
| # and it must have one of the following values: |
| # |
| # -glob Pattern is a glob-style pattern which is |
| # matched against each component path using the same rules as |
| # the string match command. |
| # |
| # -regexp Pattern is treated as a regular expression |
| # and matched against each component path using the same |
| # rules as the regexp command. |
| # |
| # The default mode is -glob. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::path { args } { |
| |
| set len [llength $args] |
| if { $len < 1 || $len > 2 } { |
| error "wrong # args: should be \ |
| \"$itk_component(hull) path ?mode?> <pattern>\"" |
| } |
| |
| set pathList [array names _pathMap] |
| |
| set len [llength $args] |
| switch -- $len { |
| 1 { |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Case: no search modes given |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| set pattern [lindex $args 0] |
| set found [lindex $pathList [lsearch -glob $pathList $pattern]] |
| } |
| 2 { |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Case: search modes present (-glob, -regexp) |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| set options [lindex $args 0] |
| set pattern [lindex $args 1] |
| set found \ |
| [lindex $pathList [lsearch $options $pathList $pattern]] |
| } |
| default { |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Case: wrong # arguments |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| error "wrong # args: \ |
| should be \"$itk_component(hull) path ?-glob? ?-regexp? pattern\"" |
| } |
| } |
| |
| return $found |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # METHOD: type path |
| # |
| # Returns the type of the component given by entryCom- |
| # ponentPathName. For menu entries, this is the type argument |
| # passed to the add/insert widget command when the entry was |
| # created, such as command or separator. Othewise it is either |
| # a menubutton or a menu. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::type { path } { |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Path Conversions |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| set path [_parsePath $path] |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Error Handling: does the path exist? |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| if { [catch {set index $_pathMap($path)} ] } { |
| error "bad path \"$path\"" |
| } |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # ENTRY, Ask TK for type |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| if { [regexp {^[0-9]+$} $index] } { |
| # get the menu path from the entry path name |
| set tkMenuPath [_entryPathToTkMenuPath $path] |
| |
| # call the menu's type command, adjusting index based on tearoff |
| set type [$tkMenuPath type [_getTkIndex $tkMenuPath $index]] |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # MENUBUTTON, MENU, or FRAME |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| } else { |
| # should not happen, but have a path that is not a valid window. |
| if { [catch {set className [winfo class $_pathMap($path)]}] } { |
| error "serious error: \"$path\" is not a valid window" |
| } |
| # get the classname, look it up, get index, us it to look up type |
| set type [ lindex \ |
| {frame menubutton menu} \ |
| [lsearch { Frame Menubutton Menu } $className] \ |
| ] |
| } |
| return $type |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # METHOD: yposition entryPath |
| # |
| # Returns a decimal string giving the y-coordinate within |
| # the menu window of the topmost pixel in the entry specified |
| # by componentPathName. If the componentPathName is not an |
| # entry, an error is issued. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::yposition { entryPath } { |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Path Conversions |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| set entryPath [_parsePath $entryPath] |
| set index $_pathMap($entryPath) |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Error Handling |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| # first verify that entryPath is actually a path to |
| # an entry and not to menu, menubutton, etc. |
| if { ! [regexp {^[0-9]+$} $index] } { |
| error "bad value: entryPath is not an entry" |
| } |
| |
| # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Call yposition command |
| # ''''''''''''''''''''''''''''''''''''''''''''''''''''' |
| # get the menu path from the entry path name |
| set tkMenuPath [_entryPathToTkMenuPath $entryPath] |
| |
| # call the menu's yposition command, adjusting index based on tearoff |
| return [$tkMenuPath yposition [_getTkIndex $tkMenuPath $index]] |
| |
| } |
| |
| # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
| # PARSING METHODS |
| # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
| # ------------------------------------------------------------- |
| # |
| # PARSING METHOD: menubutton |
| # |
| # This method is invoked via an evaluation of the -menubuttons |
| # option for the Menubar. |
| # |
| # It adds a new menubutton and processes any -menu options |
| # for creating entries on the menu pane associated with the |
| # menubutton |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::menubutton { menuName args } { |
| eval "add menubutton .$menuName $args" |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PARSING METHOD: options |
| # |
| # This method is invoked via an evaluation of the -menu |
| # option for menubutton commands. |
| # |
| # It configures the current menu ($_ourMenuPath) with the options |
| # that follow (args) |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::options { args } { |
| eval "$_tkMenuPath configure $args" |
| } |
| |
| |
| # ------------------------------------------------------------- |
| # |
| # PARSING METHOD: command |
| # |
| # This method is invoked via an evaluation of the -menu |
| # option for menubutton commands. |
| # |
| # It adds a new command entry to the current menu, $_ourMenuPath |
| # naming it $cmdName. Since this is the most common case when |
| # creating menus, streamline it by duplicating some code from |
| # the add{} method. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::command { cmdName args } { |
| set path $_ourMenuPath.$cmdName |
| |
| # error checking |
| regsub {.*[.]} $path "" segName |
| if [regexp {^(menu|last|end|[0-9]+)$} $segName] { |
| error "bad name \"$segName\": user created component \ |
| path names may not end with \ |
| \"end\", \"last\", \"menu\", \ |
| or be an integer" |
| } |
| |
| eval _addEntry command $path $args |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PARSING METHOD: checkbutton |
| # |
| # This method is invoked via an evaluation of the -menu |
| # option for menubutton/cascade commands. |
| # |
| # It adds a new checkbutton entry to the current menu, $_ourMenuPath |
| # naming it $chkName. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::checkbutton { chkName args } { |
| eval "add checkbutton $_ourMenuPath.$chkName $args" |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PARSING METHOD: radiobutton |
| # |
| # This method is invoked via an evaluation of the -menu |
| # option for menubutton/cascade commands. |
| # |
| # It adds a new radiobutton entry to the current menu, $_ourMenuPath |
| # naming it $radName. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::radiobutton { radName args } { |
| eval "add radiobutton $_ourMenuPath.$radName $args" |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PARSING METHOD: separator |
| # |
| # This method is invoked via an evaluation of the -menu |
| # option for menubutton/cascade commands. |
| # |
| # It adds a new separator entry to the current menu, $_ourMenuPath |
| # naming it $sepName. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::separator { sepName args } { |
| eval $_tkMenuPath add separator |
| set _pathMap($_ourMenuPath.$sepName) [_getPdIndex $_tkMenuPath end] |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PARSING METHOD: cascade |
| # |
| # This method is invoked via an evaluation of the -menu |
| # option for menubutton/cascade commands. |
| # |
| # It adds a new cascade entry to the current menu, $_ourMenuPath |
| # naming it $casName. It processes the -menu option if present, |
| # adding a new menu pane and its associated entries found. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::cascade { casName args } { |
| |
| # Save the current menu we are adding to, cascade can change |
| # the current menu through -menu options. |
| set saveOMP $_ourMenuPath |
| set saveTKP $_tkMenuPath |
| |
| eval "add cascade $_ourMenuPath.$casName $args" |
| |
| # Restore the saved menu states so that the next entries of |
| # the -menu/-menubuttons we are processing will be at correct level. |
| set _ourMenuPath $saveOMP |
| set _tkMenuPath $saveTKP |
| } |
| |
| # ... A P I S U P P O R T M E T H O D S... |
| |
| # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
| # MENU ADD, INSERT, DELETE |
| # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _addMenuButton |
| # |
| # Makes a new menubutton & associated -menu, pack appended |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_addMenuButton { buttonName args} { |
| |
| eval "_makeMenuButton $buttonName $args" |
| |
| #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Pack at end, adjust for help buttonName |
| # '''''''''''''''''''''''''''''''''' |
| if { $buttonName == "help" } { |
| pack $itk_component($buttonName) -side right |
| } else { |
| pack $itk_component($buttonName) -side left |
| } |
| |
| return $itk_component($buttonName) |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _insertMenuButton |
| # |
| # inserts a menubutton named $buttonName on a menu bar before |
| # another menubutton specified by $beforeMenuPath |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_insertMenuButton { beforeMenuPath buttonName args} { |
| |
| eval "_makeMenuButton $buttonName $args" |
| |
| #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Pack before the $beforeMenuPath |
| # '''''''''''''''''''''''''''''''' |
| set beforeTkMenu $_pathMap($beforeMenuPath) |
| regsub {[.]menu$} $beforeTkMenu "" beforeTkMenu |
| pack $itk_component(menubar).$buttonName \ |
| -side left \ |
| -before $beforeTkMenu |
| |
| return $itk_component($buttonName) |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _makeMenuButton |
| # |
| # creates a menubutton named buttonName on the menubar with args. |
| # The -menu option if present will trigger attaching a menu pane. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_makeMenuButton {buttonName args} { |
| |
| #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Capture the -menu option if present |
| # ''''''''''''''''''''''''''''''''''' |
| array set temp $args |
| if { [::info exists temp(-menu)] } { |
| # We only keep this in case of menuconfigure or menucget |
| set _menuOption(.$buttonName) $temp(-menu) |
| set menuEvalStr $temp(-menu) |
| } else { |
| set menuEvalStr {} |
| } |
| |
| # attach the actual menu widget to the menubutton's arg list |
| set temp(-menu) $itk_component(menubar).$buttonName.menu |
| set args [array get temp] |
| |
| #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Create menubutton component |
| # '''''''''''''''''''''''''''''''' |
| itk_component add $buttonName { |
| eval ::menubutton \ |
| $itk_component(menubar).$buttonName \ |
| $args |
| } { |
| keep \ |
| -activebackground \ |
| -activeforeground \ |
| -anchor \ |
| -background \ |
| -borderwidth \ |
| -cursor \ |
| -disabledforeground \ |
| -font \ |
| -foreground \ |
| -highlightbackground \ |
| -highlightcolor \ |
| -highlightthickness \ |
| -justify \ |
| -padx \ |
| -pady \ |
| -wraplength |
| } |
| |
| set _pathMap(.$buttonName) $itk_component($buttonName) |
| |
| _makeMenu \ |
| $buttonName-menu \ |
| $itk_component($buttonName).menu \ |
| .$buttonName \ |
| $menuEvalStr |
| |
| return $itk_component($buttonName) |
| |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _makeMenu |
| # |
| # Creates a menu. |
| # It then evaluates the $menuEvalStr to create entries on the menu. |
| # |
| # Assumes the existence of $itk_component($buttonName) |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_makeMenu \ |
| { componentName widgetName menuPath menuEvalStr } { |
| |
| #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Create menu component |
| # '''''''''''''''''''''''''''''''' |
| itk_component add $componentName { |
| ::menu $widgetName |
| } { |
| keep \ |
| -activebackground \ |
| -activeborderwidth \ |
| -activeforeground \ |
| -background \ |
| -borderwidth \ |
| -cursor \ |
| -disabledforeground \ |
| -font \ |
| -foreground |
| } |
| |
| set _pathMap($menuPath.menu) $itk_component($componentName) |
| |
| #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Attach help handler to this menu |
| # '''''''''''''''''''''''''''''''' |
| bind $itk_component($componentName) <<MenuSelect>> \ |
| [itcl::code $this _helpHandler $menuPath.menu] |
| |
| #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Handle -menu |
| #''''''''''''''''''''''''''''''''' |
| set _ourMenuPath $menuPath |
| set _tkMenuPath $itk_component($componentName) |
| |
| # |
| # A zero parseLevel says we are at the top of the parse tree, |
| # so get the context scope level and do a subst for the menuEvalStr. |
| # |
| if { $_parseLevel == 0 } { |
| set _callerLevel [_getCallerLevel] |
| } |
| |
| # |
| # bump up the parse level, so if we get called via the 'eval $menuEvalStr' |
| # we know to skip the above steps... |
| # |
| incr _parseLevel |
| eval $menuEvalStr |
| |
| # |
| # leaving, so done with this parse level, so bump it back down |
| # |
| incr _parseLevel -1 |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _substEvalStr |
| # |
| # This performs the substitution and evaluation of $ [], \ found |
| # in the -menubutton/-menus options |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_substEvalStr { evalStr } { |
| upvar $evalStr evalStrRef |
| set evalStrRef [uplevel $_callerLevel [list subst $evalStrRef]] |
| } |
| |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _deleteMenu |
| # |
| # _deleteMenu menuPath ?menuPath2? |
| # |
| # deletes menuPath or from menuPath to menuPath2 |
| # |
| # Menu paths may be formed in one of two ways |
| # .MENUBAR.menuName where menuName is the name of the menu |
| # .MENUBAR.menuName.menu where menuName is the name of the menu |
| # |
| # The basic rule is '.menu' is not needed. |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_deleteMenu { menuPath {menuPath2 {}} } { |
| |
| if { $menuPath2 == "" } { |
| # get a corrected path (subst for number, last, end) |
| set path [_parsePath $menuPath] |
| |
| _deleteAMenu $path |
| |
| } else { |
| # gets the list of menus in interface order |
| set menuList [_getMenuList] |
| |
| # ... get the start menu and the last menu ... |
| |
| # get a corrected path (subst for number, last, end) |
| set menuStartPath [_parsePath $menuPath] |
| |
| regsub {[.]menu$} $menuStartPath "" menuStartPath |
| |
| set menuEndPath [_parsePath $menuPath2] |
| |
| regsub {[.]menu$} $menuEndPath "" menuEndPath |
| |
| # get the menu position (0 based) of the start and end menus. |
| set start [lsearch -exact $menuList $menuStartPath] |
| if { $start == -1 } { |
| error "bad menu path \"$menuStartPath\": \ |
| should be one of $menuList" |
| } |
| set end [lsearch -exact $menuList $menuEndPath] |
| if { $end == -1 } { |
| error "bad menu path \"$menuEndPath\": \ |
| should be one of $menuList" |
| } |
| |
| # now create the list from this range of menus |
| set delList [lrange $menuList $start $end] |
| |
| # walk thru them deleting each menu. |
| # this list has no .menu on the end. |
| foreach m $delList { |
| _deleteAMenu $m.menu |
| } |
| } |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _deleteAMenu |
| # |
| # _deleteMenu menuPath |
| # |
| # deletes a single Menu (menubutton and menu pane with entries) |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_deleteAMenu { path } { |
| |
| # We will normalize the path to not include the '.menu' if |
| # it is on the path already. |
| |
| regsub {[.]menu$} $path "" menuButtonPath |
| regsub {.*[.]} $menuButtonPath "" buttonName |
| |
| # Loop through and destroy any cascades, etc on menu. |
| set entryList [_getEntryList $menuButtonPath] |
| foreach entry $entryList { |
| _deleteEntry $entry |
| } |
| |
| # Delete the menubutton and menu components... |
| destroy $itk_component($buttonName-menu) |
| destroy $itk_component($buttonName) |
| |
| # This is because of some itcl bug that doesn't delete |
| # the component on the destroy in some cases... |
| catch {itk_component delete $buttonName-menu} |
| catch {itk_component delete $buttonName} |
| |
| # unset our paths |
| _unsetPaths $menuButtonPath |
| |
| } |
| |
| # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
| # ENTRY ADD, INSERT, DELETE |
| # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _addEntry |
| # |
| # Adds an entry to menu. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_addEntry { type path args } { |
| |
| # Error Checking |
| # '''''''''''''' |
| # the path should not end with '.menu' |
| # Not needed -- already checked by add{} |
| # if { [regexp {[.]menu$} $path] } { |
| # error "bad entry path: \"$path\". \ |
| # The name \"menu\" is reserved for menu panes" |
| # } |
| |
| # get the tkMenuPath |
| set tkMenuPath [_entryPathToTkMenuPath $path] |
| if { $tkMenuPath == "" } { |
| error "bad entry path: \"$path\". The menu path prefix is not valid" |
| } |
| |
| # get the -helpstr option if present |
| array set temp $args |
| if { [::info exists temp(-helpstr)] } { |
| set helpStr $temp(-helpstr) |
| unset temp(-helpstr) |
| } else { |
| set helpStr {} |
| } |
| set args [array get temp] |
| |
| # Handle CASCADE |
| # '''''''''''''' |
| # if this is a cascade go ahead and add in the menu... |
| if { $type == "cascade" } { |
| eval [list _addCascade $tkMenuPath $path] $args |
| # Handle Non-CASCADE |
| # '''''''''''''''''' |
| } else { |
| # add the entry if one doesn't already exist with the same |
| # command name |
| if [::info exists _pathMap($path)] { |
| set cmdname [lindex [split $path .] end] |
| error "Cannot add $type \"$cmdname\". A menu item already\ |
| exists with this name." |
| } |
| eval [list $tkMenuPath add $type] $args |
| set _pathMap($path) [_getPdIndex $tkMenuPath end] |
| } |
| |
| # Remember the help string |
| set _helpString($path) $helpStr |
| |
| return $_pathMap($path) |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _addCascade |
| # |
| # Creates a cascade button. Handles the -menu option |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_addCascade { tkMenuPath path args } { |
| |
| # get the cascade name from our path |
| regsub {.*[.]} $path "" cascadeName |
| |
| #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Capture the -menu option if present |
| # ''''''''''''''''''''''''''''''''''' |
| array set temp $args |
| if { [::info exists temp(-menu)] } { |
| set menuEvalStr $temp(-menu) |
| } else { |
| set menuEvalStr {} |
| } |
| |
| # attach the menu pane |
| set temp(-menu) $tkMenuPath.$cascadeName |
| set args [array get temp] |
| |
| # Create the cascade entry |
| eval $tkMenuPath add cascade $args |
| |
| # Keep the -menu string in case of menuconfigure or menucget |
| if { $menuEvalStr != "" } { |
| set _menuOption($path) $menuEvalStr |
| } |
| |
| # update our pathmap |
| set _pathMap($path) [_getPdIndex $tkMenuPath end] |
| |
| _makeMenu \ |
| $cascadeName-menu \ |
| $tkMenuPath.$cascadeName \ |
| $path \ |
| $menuEvalStr |
| |
| #return $itk_component($cascadeName) |
| |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _insertEntry |
| # |
| # inserts an entry on a menu before entry given by beforeEntryPath. |
| # The added entry is of type TYPE and its name is NAME. ARGS are |
| # passed for customization of the entry. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_insertEntry { beforeEntryPath type name args } { |
| |
| # convert entryPath to an index value |
| set bfIndex $_pathMap($beforeEntryPath) |
| |
| # first verify that beforeEntryPath is actually a path to |
| # an entry and not to menu, menubutton, etc. |
| if { ! [regexp {^[0-9]+$} $bfIndex] } { |
| error "bad entry path: $beforeEntryPath is not an entry" |
| } |
| |
| # get the menu path from the entry path name |
| regsub {[.][^.]*$} $beforeEntryPath "" menuPathPrefix |
| set tkMenuPath $_pathMap($menuPathPrefix.menu) |
| |
| # If this entry already exists in the path map, throw an error. |
| if [::info exists _pathMap($menuPathPrefix.$name)] { |
| error "Cannot insert $type \"$name\". A menu item already\ |
| exists with this name." |
| } |
| |
| # INDEX is zero based at this point. |
| |
| # ENTRIES is a zero based list... |
| set entries [_getEntryList $menuPathPrefix] |
| |
| # |
| # Adjust the entries after the inserted item, to have |
| # the correct index numbers. Note, we stay zero based |
| # even though tk flips back and forth depending on tearoffs. |
| # |
| for {set i $bfIndex} {$i < [llength $entries]} {incr i} { |
| # path==entry path in numerical order |
| set path [lindex $entries $i] |
| |
| # add one to each entry after the inserted one. |
| set _pathMap($path) [expr {$i + 1}] |
| } |
| |
| # get the -helpstr option if present |
| array set temp $args |
| if { [::info exists temp(-helpstr)] } { |
| set helpStr $temp(-helpstr) |
| unset temp(-helpstr) |
| } else { |
| set helpStr {} |
| } |
| set args [array get temp] |
| |
| set path $menuPathPrefix.$name |
| |
| # Handle CASCADE |
| # '''''''''''''' |
| # if this is a cascade go ahead and add in the menu... |
| if { [string match cascade $type] } { |
| |
| if { [ catch {eval "_insertCascade \ |
| $bfIndex $tkMenuPath $path $args"} errMsg ]} { |
| for {set i $bfIndex} {$i < [llength $entries]} {incr i} { |
| # path==entry path in numerical order |
| set path [lindex $entries $i] |
| |
| # sub the one we added earlier. |
| set _pathMap($path) [expr {$_pathMap($path) - 1}] |
| # @@ delete $hs |
| } |
| error $errMsg |
| } |
| |
| # Handle Entry |
| # '''''''''''''' |
| } else { |
| |
| # give us a zero or 1-based index based on tear-off menu status |
| # invoke the menu's insert command |
| if { [catch {eval "$tkMenuPath insert \ |
| [_getTkIndex $tkMenuPath $bfIndex] $type $args"} errMsg]} { |
| for {set i $bfIndex} {$i < [llength $entries]} {incr i} { |
| # path==entry path in numerical order |
| set path [lindex $entries $i] |
| |
| # sub the one we added earlier. |
| set _pathMap($path) [expr {$_pathMap($path) - 1}] |
| # @@ delete $hs |
| } |
| error $errMsg |
| } |
| |
| |
| # add the helpstr option to our options list (attach to entry) |
| set _helpString($path) $helpStr |
| |
| # Insert the new entry path into pathmap giving it an index value |
| set _pathMap($menuPathPrefix.$name) $bfIndex |
| |
| } |
| |
| return [_getTkIndex $tkMenuPath $bfIndex] |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _insertCascade |
| # |
| # Creates a cascade button. Handles the -menu option |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_insertCascade { bfIndex tkMenuPath path args } { |
| |
| # get the cascade name from our path |
| regsub {.*[.]} $path "" cascadeName |
| |
| #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, |
| # Capture the -menu option if present |
| # ''''''''''''''''''''''''''''''''''' |
| array set temp $args |
| if { [::info exists temp(-menu)] } { |
| # Keep the -menu string in case of menuconfigure or menucget |
| set _menuOption($path) $temp(-menu) |
| set menuEvalStr $temp(-menu) |
| } else { |
| set menuEvalStr {} |
| } |
| |
| # attach the menu pane |
| set temp(-menu) $tkMenuPath.$cascadeName |
| set args [array get temp] |
| |
| # give us a zero or 1-based index based on tear-off menu status |
| # invoke the menu's insert command |
| eval "$tkMenuPath insert \ |
| [_getTkIndex $tkMenuPath $bfIndex] cascade $args" |
| |
| # Insert the new entry path into pathmap giving it an index value |
| set _pathMap($path) $bfIndex |
| _makeMenu \ |
| $cascadeName-menu \ |
| $tkMenuPath.$cascadeName \ |
| $path \ |
| $menuEvalStr |
| |
| #return $itk_component($cascadeName) |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _deleteEntry |
| # |
| # _deleteEntry entryPath ?entryPath2? |
| # |
| # either |
| # deletes the entry entryPath |
| # or |
| # deletes the entries from entryPath to entryPath2 |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_deleteEntry { entryPath {entryPath2 {}} } { |
| |
| if { $entryPath2 == "" } { |
| # get a corrected path (subst for number, last, end) |
| set path [_parsePath $entryPath] |
| |
| set entryIndex $_pathMap($path) |
| if { $entryIndex == -1 } { |
| error "bad value for pathName: \ |
| $entryPath in call to delet" |
| } |
| |
| # get the type, if cascade, we will want to delete menu |
| set type [type $path] |
| |
| # ... munge up the menu name ... |
| |
| # the tkMenuPath is looked up with the .menu added to lookup |
| # strip off the entry component |
| regsub {[.][^.]*$} $path "" menuPath |
| set tkMenuPath $_pathMap($menuPath.menu) |
| |
| # get the ordered entry list |
| set entries [_getEntryList $menuPath] |
| |
| # ... Fix up path entry indices ... |
| |
| # delete the path from the map |
| unset _pathMap([lindex $entries $entryIndex]) |
| |
| # Subtract off 1 for each entry below the deleted one. |
| for {set i [expr {$entryIndex + 1}]} \ |
| {$i < [llength $entries]} \ |
| {incr i} { |
| set epath [lindex $entries $i] |
| incr _pathMap($epath) -1 |
| } |
| |
| # ... Delete the menu entry widget ... |
| |
| # delete the menu entry, ajusting index for TK |
| $tkMenuPath delete [_getTkIndex $tkMenuPath $entryIndex] |
| |
| if { $type == "cascade" } { |
| regsub {.*[.]} $path "" cascadeName |
| destroy $itk_component($cascadeName-menu) |
| |
| # This is because of some itcl bug that doesn't delete |
| # the component on the destroy in some cases... |
| catch {itk_component delete $cascadeName-menu} |
| |
| _unsetPaths $path |
| } |
| |
| } else { |
| # get a corrected path (subst for number, last, end) |
| set path1 [_parsePath $entryPath] |
| set path2 [_parsePath $entryPath2] |
| |
| set fromEntryIndex $_pathMap($path1) |
| if { $fromEntryIndex == -1 } { |
| error "bad value for entryPath1: \ |
| $entryPath in call to delet" |
| } |
| set toEntryIndex $_pathMap($path2) |
| if { $toEntryIndex == -1 } { |
| error "bad value for entryPath2: \ |
| $entryPath2 in call to delet" |
| } |
| # ... munge up the menu name ... |
| |
| # the tkMenuPath is looked up with the .menu added to lookup |
| # strip off the entry component |
| regsub {[.][^.]*$} $path1 "" menuPath |
| set tkMenuPath $_pathMap($menuPath.menu) |
| |
| # get the ordered entry list |
| set entries [_getEntryList $menuPath] |
| |
| # ... Fix up path entry indices ... |
| |
| # delete the range from the pathMap list |
| for {set i $fromEntryIndex} {$i <= $toEntryIndex} {incr i} { |
| unset _pathMap([lindex $entries $i]) |
| } |
| |
| # Subtract off 1 for each entry below the deleted range. |
| # Loop from one below the bottom delete entry to end list |
| for {set i [expr {$toEntryIndex + 1}]} \ |
| {$i < [llength $entries]} \ |
| {incr i} { |
| # take this path and sets its index back by size of |
| # deleted range. |
| set path [lindex $entries $i] |
| set _pathMap($path) \ |
| [expr {$_pathMap($path) - \ |
| (($toEntryIndex - $fromEntryIndex) + 1)}] |
| } |
| |
| # ... Delete the menu entry widget ... |
| |
| # delete the menu entry, ajusting index for TK |
| $tkMenuPath delete \ |
| [_getTkIndex $tkMenuPath $fromEntryIndex] \ |
| [_getTkIndex $tkMenuPath $toEntryIndex] |
| |
| } |
| } |
| |
| # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
| # CONFIGURATION SUPPORT |
| # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _configureMenu |
| # |
| # This configures a menu. A menu is a true tk widget, thus we |
| # pass the tkPath variable. This path may point to either a |
| # menu button (does not end with the name 'menu', or a menu |
| # which ends with the name 'menu' |
| # |
| # path : our Menubar path name to this menu button or menu pane. |
| # if we end with the name '.menu' then it is a menu pane. |
| # tkPath : the path to the corresponding Tk menubutton or menu. |
| # args : the args for configuration |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_configureMenu { path tkPath {option {}} args } { |
| |
| set class [winfo class $tkPath] |
| |
| if { $option == "" } { |
| # No arguments: return all options |
| set configList [$tkPath configure] |
| |
| if { [info exists _menuOption($path)] } { |
| lappend configList [list -menu menu Menu {} $_menuOption($path)] |
| } else { |
| lappend configList [list -menu menu Menu {} {}] |
| } |
| if { [info exists _helpString($path)] } { |
| lappend configList [list -helpstr helpStr HelpStr {} \ |
| $_helpString($path)] |
| } else { |
| lappend configList [list -helpstr helpStr HelpStr {} {}] |
| } |
| return $configList |
| |
| } elseif {$args == "" } { |
| if { $option == "-menu" } { |
| if { [info exists _menuOption($path)] } { |
| return [list -menu menu Menu {} $_menuOption($path)] |
| } else { |
| return [list -menu menu Menu {} {}] |
| } |
| } elseif { $option == "-helpstr" } { |
| if { [info exists _helpString($path)] } { |
| return [list -helpstr helpStr HelpStr {} $_helpString($path)] |
| } else { |
| return [list -helpstr helpStr HelpStr {} {}] |
| } |
| } else { |
| # ... OTHERWISE, let Tk get it. |
| return [$tkPath configure $option] |
| } |
| } else { |
| set args [concat $option $args] |
| |
| # If this is a menubutton, and has -menu option, process it |
| if { $class == "Menubutton" && [regexp -- {-menu} $args] } { |
| eval _configureMenuOption menubutton $path $args |
| } else { |
| eval $tkPath configure $args |
| } |
| return "" |
| } |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _configureMenuOption |
| # |
| # Allows for configuration of the -menu option on |
| # menubuttons and cascades |
| # |
| # find out if we are the last menu, or are before one. |
| # delete the old menu. |
| # if we are the last, then add us back at the end |
| # if we are before another menu, get the beforePath |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_configureMenuOption { type path args } { |
| |
| regsub {[.][^.]*$} $path "" pathPrefix |
| |
| if { $type == "menubutton" } { |
| set menuList [_getMenuList] |
| set pos [lsearch $menuList $path] |
| if { $pos == ([llength $menuList] - 1) } { |
| set insert false |
| } else { |
| set insert true |
| } |
| } elseif { $type == "cascade" } { |
| set lastEntryPath [_parsePath $pathPrefix.last] |
| if { $lastEntryPath == $path } { |
| set insert false |
| } else { |
| set insert true |
| } |
| set pos [index $path] |
| |
| } |
| |
| |
| eval "delete $pathPrefix.$pos" |
| if { $insert } { |
| # get name from path... |
| regsub {.*[.]} $path "" name |
| |
| eval insert $pathPrefix.$pos $type \ |
| $name $args |
| } else { |
| eval add $type $path $args |
| } |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _configureMenuEntry |
| # |
| # This configures a menu entry. A menu entry is either a command, |
| # radiobutton, separator, checkbutton, or a cascade. These have |
| # a corresponding Tk index value for the corresponding tk menu |
| # path. |
| # |
| # path : our Menubar path name to this menu entry. |
| # index : the t |
| # args : the args for configuration |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_configureMenuEntry { path index {option {}} args } { |
| |
| set type [type $path] |
| |
| # set len [llength $args] |
| |
| # get the menu path from the entry path name |
| set tkMenuPath [_entryPathToTkMenuPath $path] |
| |
| if { $option == "" } { |
| set configList [$tkMenuPath entryconfigure \ |
| [_getTkIndex $tkMenuPath $index]] |
| |
| if { $type == "cascade" } { |
| if { [info exists _menuOption($path)] } { |
| lappend configList [list -menu menu Menu {} \ |
| $_menuOption($path)] |
| } else { |
| lappend configList [list -menu menu Menu {} {}] |
| } |
| } |
| if { [info exists _helpString($path)] } { |
| lappend configList [list -helpstr helpStr HelpStr {} \ |
| $_helpString($path)] |
| } else { |
| lappend configList [list -helpstr helpStr HelpStr {} {}] |
| } |
| return $configList |
| |
| } elseif { $args == "" } { |
| if { $option == "-menu" } { |
| if { [info exists _menuOption($path)] } { |
| return [list -menu menu Menu {} $_menuOption($path)] |
| } else { |
| return [list -menu menu Menu {} {}] |
| } |
| } elseif { $option == "-helpstr" } { |
| if { [info exists _helpString($path)] } { |
| return [list -helpstr helpStr HelpStr {} \ |
| $_helpString($path)] |
| } else { |
| return [list -helpstr helpStr HelpStr {} {}] |
| } |
| } else { |
| # ... OTHERWISE, let Tk get it. |
| return [$tkMenuPath entryconfigure \ |
| [_getTkIndex $tkMenuPath $index] $option] |
| } |
| } else { |
| array set temp [concat $option $args] |
| |
| # ... Store -helpstr val,strip out -helpstr val from args |
| if { [::info exists temp(-helpstr)] } { |
| set _helpString($path) $temp(-helpstr) |
| unset temp(-helpstr) |
| } |
| |
| set args [array get temp] |
| if { $type == "cascade" && [::info exists temp(-menu)] } { |
| eval "_configureMenuOption cascade $path $args" |
| } else { |
| # invoke the menu's entryconfigure command |
| # being careful to ajust the INDEX to be 0 or 1 based |
| # depending on the tearoff status |
| # if the stripping process brought us down to no options |
| # to set, then forget the configure of widget. |
| if { [llength $args] != 0 } { |
| eval $tkMenuPath entryconfigure \ |
| [_getTkIndex $tkMenuPath $index] $args |
| } |
| } |
| return "" |
| } |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _unsetPaths |
| # |
| # comment |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_unsetPaths { parent } { |
| |
| # first get the complete list of all menu paths |
| set pathList [array names _pathMap] |
| |
| # for each path that matches parent prefix, unset it. |
| foreach path $pathList { |
| if { [regexp [subst -nocommands {^$parent}] $path] } { |
| unset _pathMap($path) |
| } |
| } |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _entryPathToTkMenuPath |
| # |
| # Takes an entry path like .mbar.file.new and changes it to |
| # .mbar.file.menu and performs a lookup in the pathMap to |
| # get the corresponding menu widget name for tk |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_entryPathToTkMenuPath {entryPath} { |
| |
| # get the menu path from the entry path name |
| # by stripping off the entry component of the path |
| regsub {[.][^.]*$} $entryPath "" menuPath |
| |
| # the tkMenuPath is looked up with the .menu added to lookup |
| if { [catch {set tkMenuPath $_pathMap($menuPath.menu)}] } { |
| return "" |
| } else { |
| return $_pathMap($menuPath.menu) |
| } |
| } |
| |
| |
| # ------------------------------------------------------------- |
| # |
| # These two methods address the issue of menu entry indices being |
| # zero-based when the menu is not a tearoff menu and 1-based when |
| # it is a tearoff menu. Our strategy is to hide this difference. |
| # |
| # _getTkIndex returns the index as tk likes it: 0 based for non-tearoff |
| # and 1 based for tearoff menus. |
| # |
| # _getPdIndex (get pulldown index) always returns it as 0 based. |
| # |
| # ------------------------------------------------------------- |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _getTkIndex |
| # |
| # give us a zero or 1-based answer depending on the tearoff |
| # status of the menu. If the menu denoted by tkMenuPath is a |
| # tearoff menu it returns a 1-based result, otherwise a |
| # zero-based result. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_getTkIndex { tkMenuPath tkIndex} { |
| |
| # if there is a tear off make it 1-based index |
| if { [$tkMenuPath cget -tearoff] } { |
| incr tkIndex |
| } |
| |
| return $tkIndex |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _getPdIndex |
| # |
| # Take a tk index and give me a zero based numerical index |
| # |
| # Ask the menu widget for the index of the entry denoted by |
| # 'tkIndex'. Then if the menu is a tearoff adjust the value |
| # to be zero based. |
| # |
| # This method returns the index as if tearoffs did not exist. |
| # Always returns a zero-based index. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_getPdIndex { tkMenuPath tkIndex } { |
| |
| # get the index from the tk menu |
| # this 0 based for non-tearoff and 1-based for tearoffs |
| set pdIndex [$tkMenuPath index $tkIndex] |
| |
| # if there is a tear off make it 0-based index |
| if { [$tkMenuPath cget -tearoff] } { |
| incr pdIndex -1 |
| } |
| |
| return $pdIndex |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _getMenuList |
| # |
| # Returns the list of menus in the order they are on the interface |
| # returned list is a list of our menu paths |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_getMenuList { } { |
| # get the menus that are packed |
| set tkPathList [pack slaves $itk_component(menubar)] |
| |
| regsub -- {[.]} $itk_component(hull) "" mbName |
| regsub -all -- "\[.\]$mbName\[.\]menubar\[.\]" $tkPathList "." menuPathList |
| |
| return $menuPathList |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _getEntryList |
| # |
| # |
| # This method looks at a menupath and gets all the entries and |
| # returns a list of all the entry path names in numerical order |
| # based on their index values. |
| # |
| # MENU is the path to a menu, like .mbar.file.menu or .mbar.file |
| # we will calculate a menuPath from this: .mbar.file |
| # then we will build a list of entries in this menu excluding the |
| # path .mbar.file.menu |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_getEntryList { menu } { |
| |
| # if it ends with menu, clip it off |
| regsub {[.]menu$} $menu "" menuPath |
| |
| # first get the complete list of all menu paths |
| set pathList [array names _pathMap] |
| |
| set numEntries 0 |
| # iterate over the pathList and put on menuPathList those |
| # that match the menuPattern |
| foreach path $pathList { |
| # if this path is on the menuPath's branch |
| if { [regexp [subst -nocommands {$menuPath[.][^.]*$}] $path] } { |
| # if not a menu itself |
| if { ! [regexp {[.]menu$} $path] } { |
| set orderedList($_pathMap($path)) $path |
| incr numEntries |
| } |
| } |
| } |
| set entryList {} |
| |
| for {set i 0} {$i < $numEntries} {incr i} { |
| lappend entryList $orderedList($i) |
| } |
| |
| return $entryList |
| |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _parsePath |
| # |
| # given path, PATH, _parsePath splits the path name into its |
| # component segments. It then puts the name back together one |
| # segment at a time and calls _getSymbolicPath to replace the |
| # keywords 'last' and 'end' as well as numeric digits. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_parsePath { path } { |
| set segments [split [string trimleft $path .] .] |
| |
| set concatPath "" |
| foreach seg $segments { |
| |
| set concatPath [_getSymbolicPath $concatPath $seg] |
| |
| if { [catch {set _pathMap($concatPath)} ] } { |
| error "bad path: \"$path\" does not exist. \"$seg\" not valid" |
| } |
| } |
| return $concatPath |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _getSymbolicPath |
| # |
| # Given a PATH, _getSymbolicPath looks for the last segment of |
| # PATH to contain: a number, the keywords last or end. If one |
| # of these it figures out how to get us the actual pathname |
| # to the searched widget |
| # |
| # Implementor's notes: |
| # Surely there is a shorter way to do this. The only diff |
| # for non-numeric is getting the llength of the correct list |
| # It is hard to know this upfront so it seems harder to generalize. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_getSymbolicPath { parent segment } { |
| |
| # if the segment is a number, then look it up positionally |
| # MATCH numeric index |
| if { [regexp {^[0-9]+$} $segment] } { |
| |
| # if we have no parent, then we area menubutton |
| if { $parent == {} } { |
| set returnPath [lindex [_getMenuList] $segment] |
| } else { |
| set returnPath [lindex [_getEntryList $parent.menu] $segment] |
| } |
| |
| # MATCH 'end' or 'last' keywords. |
| } elseif { $segment == "end" || $segment == "last" } { |
| |
| # if we have no parent, then we are a menubutton |
| if { $parent == {} } { |
| set returnPath [lindex [_getMenuList] end] |
| } else { |
| set returnPath [lindex [_getEntryList $parent.menu] end] |
| } |
| } else { |
| set returnPath $parent.$segment |
| } |
| |
| return $returnPath |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _helpHandler |
| # |
| # Bound to the <Motion> event on a menu pane. This puts the |
| # help string associated with the menu entry into the |
| # status widget help area. If no help exists for the current |
| # entry, the status widget is cleared. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_helpHandler { menuPath } { |
| |
| if { $itk_option(-helpvariable) == {} } { |
| return |
| } |
| |
| set tkMenuWidget $_pathMap($menuPath) |
| |
| set entryIndex [$tkMenuWidget index active] |
| |
| # already on this item? |
| if { $entryIndex == $_entryIndex } { |
| return |
| } |
| |
| set _entryIndex $entryIndex |
| |
| if {"none" != $entryIndex} { |
| set entries [_getEntryList $menuPath] |
| |
| set menuEntryHit \ |
| [lindex $entries [_getPdIndex $tkMenuWidget $entryIndex]] |
| |
| # blank out the old one |
| set $itk_option(-helpvariable) {} |
| |
| # if there is a help string for this entry |
| if { [::info exists _helpString($menuEntryHit)] } { |
| set $itk_option(-helpvariable) $_helpString($menuEntryHit) |
| } |
| } else { |
| set $itk_option(-helpvariable) {} |
| set _entryIndex -1 |
| } |
| } |
| |
| # ------------------------------------------------------------- |
| # |
| # PRIVATE METHOD: _getCallerLevel |
| # |
| # Starts at stack frame #0 and works down till we either hit |
| # a ::Menubar stack frame or an ::itk::Archetype stack frame |
| # (the latter happens when a configure is called via the 'component' |
| # method |
| # |
| # Returns the level of the actual caller of the menubar command |
| # in the form of #num where num is the level number caller stack frame. |
| # |
| # ------------------------------------------------------------- |
| itcl::body iwidgets::Menubar::_getCallerLevel { } { |
| |
| set levelName {} |
| set levelsAreValid true |
| set level 0 |
| set callerLevel #$level |
| |
| while { $levelsAreValid } { |
| # Hit the end of the stack frame |
| if [catch {uplevel #$level {namespace current}}] { |
| set levelsAreValid false |
| set callerLevel #[expr {$level - 1}] |
| # still going |
| } else { |
| set newLevelName [uplevel #$level {namespace current}] |
| # See if we have run into the first ::Menubar level |
| if { $newLevelName == "::itk::Archetype" || \ |
| $newLevelName == "::iwidgets::Menubar" } { |
| # If so, we are done-- set the callerLevel |
| set levelsAreValid false |
| set callerLevel #[expr {$level - 1}] |
| } else { |
| set levelName $newLevelName |
| } |
| } |
| incr level |
| } |
| return $callerLevel |
| } |
| |
| |
| # |
| # The default tkMenuFind proc in menu.tcl only looks for menubuttons |
| # in frames. Since our menubuttons are within the Menubar class, the |
| # default proc won't find them during menu traversal. This proc |
| # redefines the default proc to remedy the problem. |
| #----------------------------------------------------------- |
| # BUG FIX: csmith (Chad Smith: csmith@adc.com), 3/30/99 |
| #----------------------------------------------------------- |
| # The line, "set qchild ..." below had a typo. It should be |
| # "info command $child" instead of "winfo command $child". |
| #----------------------------------------------------------- |
| proc tkMenuFind {w char} { |
| global tkPriv |
| set char [string tolower $char] |
| |
| # Added by csmith, 5/10/01, to fix a bug reported on the itcl mailing list. |
| if {$w == "."} { |
| foreach child [winfo child $w] { |
| set match [tkMenuFind $child $char] |
| if {$match != ""} { |
| return $match |
| } |
| } |
| return {} |
| } |
| |
| foreach child [winfo child $w] { |
| switch [winfo class $child] { |
| Menubutton { |
| set qchild [info command $child] |
| set char2 [string index [$qchild cget -text] \ |
| [$qchild cget -underline]] |
| if {([string compare $char [string tolower $char2]] == 0) |
| || ($char == "")} { |
| if {[$qchild cget -state] != "disabled"} { |
| return $child |
| } |
| } |
| } |
| Frame - |
| Menubar { |
| set match [tkMenuFind $child $char] |
| if {$match != ""} { |
| return $match |
| } |
| } |
| } |
| } |
| return {} |
| } |