# # 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 EMAIL: bscott@spd.dsccc.com # # @(#) $Id: menubar.itk,v 1.3 2006/09/11 20:35:55 irby 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. # ====================================================================== # # Option database default resources: # option add *Menubar*Menu*tearOff false widgetDefault option add *Menubar*activeBorderWidth 2 widgetDefault option add *Menubar*activeForeground black widgetDefault option add *Menubar*anchor center widgetDefault option add *Menubar*borderWidth 2 widgetDefault option add *Menubar*disabledForeground #a3a3a3 widgetDefault option add *Menubar*font \ "-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*" widgetDefault option add *Menubar*highlightBackground #d9d9d9 widgetDefault option add *Menubar*highlightColor Black widgetDefault option add *Menubar*highlightThickness 0 widgetDefault option add *Menubar*justify center widgetDefault option add *Menubar*padX 4p widgetDefault option add *Menubar*padY 3p widgetDefault option add *Menubar*Menubutton*relief flat widgetDefault option add *Menubar*Menu*relief raised widgetDefault option add *Menubar*wrapLength 0 widgetDefault # # Usual options. # itk::usual Menubar { keep -activebackground -activeborderwidth -activeforeground keep -background -cursor -disabledforeground -foreground keep -font } # # The Option class # # This class implements the concept of an option. # class iwidgets::Option { # # CONSTRUCTOR # constructor { args } { if { $args != "" } { uplevel $this configure $args } } #============================================================== # O P T I O N S #============================================================== public variable switch {} { } public variable name {} { } public variable class {} { } public variable default {} { } public variable value {} { } #============================================================== # P U B L I C I N T E R F A C E #============================================================== public method set { args } { } public method get { args } { } #============================================================== # D E S T R U C T O R #============================================================== destructor { } } #============================================================== # P U B L I C I M P L E M E N T A T I O N #============================================================== # # OPTION -switch # # This option specifies the switch name for the option # configbody iwidgets::Option::switch { } # # OPTION -name # # This option specifies the resource name for the option # configbody iwidgets::Option::name { } # # OPTION -class # # This option specifies the resource class for the option # configbody iwidgets::Option::class { } # # OPTION -default # # This option specifies the default value for the option # configbody iwidgets::Option::default { } # # OPTION -value # # This option specifies the current value for the option # configbody iwidgets::Option::value { } body iwidgets::Option::get { args } { upvar $args argsRef ::set len [llength $args] switch $len { 0 { return [list $switch $name $class $default $value] } 1 { if { [string match $args $switch] } { return [list $switch $name $class $default $value] #::set argsRef {} #return $value } else { return {} } } default { error "wrong # arguments: \ should be \"$itk_component(hull) get ?option?\"" } } } body iwidgets::Option::set { args } { # scan args for our switch. # if found, set our -value option and strip args. # else do nothing. upvar args argsRef ::set success false # check for 'option' in the 'args' list ::set optPos [lsearch $args $switch] # ... found it if { $optPos != -1 } { # set our -value switch ::set value [lindex $args [expr $optPos + 1]] # remove the option argument and value from the arg list ::set argsRef [lreplace $args $optPos [expr $optPos + 1]] ::set success true } return $success } class iwidgets::MenuOption { inherit iwidgets::Option constructor { args } {} } body iwidgets::MenuOption::constructor { args } { uplevel $this configure \ -switch -menu -name menu -class Menu -default {} -value {} } class iwidgets::HelpStrOption { inherit iwidgets::Option constructor { args } {} } body iwidgets::HelpStrOption::constructor { args } { uplevel $this configure \ -switch -helpstr -name helpStr -class HelpStr -default {{}} -value {{}} } 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 {} itk_option define -borderwidth borderWidth BorderWidth {} 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 {} itk_option define -justify justify Justify {} itk_option define -padx padX Pad {} itk_option define -pady padY Pad {} itk_option define -wraplength wrapLength WrapLength {} itk_option define -menubuttons menuButtons MenuButtons {} itk_option define -helpvariable helpVariable HelpVariable {} public method add { type path args } { } public method delete { args } { } public method index { path } { } public method insert { beforeComponent type name args } public method invoke { entryPath } { } public method menucget { args } { } public method menuconfigure { path args } { } public method path { args } { } public method type { path } { } public method yposition { entryPath } { } public method _leaveHandler { menuPath } { } public method _helpHandler { menuPath menuY } { } private method menubutton { menuName args } { } private method options { args } { } private method command { cmdName args } { } private method checkbutton { chkName args } { } private method radiobutton { radName args } { } private method separator { sepName args } { } private method cascade { casName args } { } private method _addMenuButton { buttonName args} { } private method _insertMenuButton { beforeMenuPath buttonName args} { } private method _makeMenuButton {buttonName args} { } private method _makeMenu { buttonName menuEvalStr } { } private method _substEvalStr { evalStr } { } private method _deleteMenu { args } { } private method _deleteAMenu { path } { } private method _addEntry { type path args } { } private method _addCascade { tkMenuPath path args } { } private method _makeCascadeMenu \ { tkMenuPath parentPath cascadeName menuEvalStr } { } private method _insertEntry { beforeEntryPath type name args } { } private method _insertCascade { bfIndex tkMenuPath path args } { } private method _deleteEntry { args } { } private method _configureMenu { path tkPath args } { } private method _configureMenuOption { type path args } { } private method _configureMenuEntry { path index args } { } private method _unsetPaths { parent } { } private method _entryPathToTkMenuPath {entryPath} { } private method _getTkIndex { tkMenuPath tkIndex} { } private method _getPdIndex { tkMenuPath tkIndex } { } private method _getMenuList { } { } private method _getEntryList { menu } { } private method _parsePath { path } { } private method _getSymbolicPath { path } { } private method _getCallerLevel { } private variable _parseLevel 0 ;# The parse level depth private variable _callerLevel #0 ;# abs level of caller private variable _pathMap ;# Array indexed by Menubar's path ;# naming, yields tk menu path private variable _entryIndex -1 ;# current entry help is displayed ;# for during help events private variable _options ;# New options for entry widgets private variable _tkMenuPath ;# last tk menu being added to private variable _ourMenuPath ;# our last valid path constructed. } # ------------------------------------------------------------------ # CONSTRUCTOR # ------------------------------------------------------------------ body iwidgets::Menubar::constructor { args } { # # 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) {}" } # # Provide a lowercase access method for the Tabset class # proc ::iwidgets::menubar { args } { uplevel ::iwidgets::Menubar $args } # ------------------------------------------------------------------ # OPTIONS # ------------------------------------------------------------------ # This first set of options are for configuring menus and/or menubuttons # at the menu level. # # ------------------------------------------------------------------ # OPTION -foreground # # menu # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::foreground { } # ------------------------------------------------------------------ # OPTION -activebackground # # menu # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::activebackground { } # ------------------------------------------------------------------ # OPTION -activeborderwidth # # menu # ------------------------------------------------------------------ configbody iwidgets::Menubar::activeborderwidth { } # ------------------------------------------------------------------ # OPTION -activeforeground # # menu # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::activeforeground { } # ------------------------------------------------------------------ # OPTION -anchor # # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::anchor { } # ------------------------------------------------------------------ # OPTION -borderwidth # # menu # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::borderwidth { } # ------------------------------------------------------------------ # OPTION -disabledforeground # # menu # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::disabledforeground { } # ------------------------------------------------------------------ # OPTION -font # # menu # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::font { } # ------------------------------------------------------------------ # OPTION -highlightbackground # # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::highlightbackground { } # ------------------------------------------------------------------ # OPTION -highlightcolor # # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::highlightcolor { } # ------------------------------------------------------------------ # OPTION -highlightthickness # # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::highlightthickness { } # ------------------------------------------------------------------ # OPTION -justify # # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::justify { } # ------------------------------------------------------------------ # OPTION -padx # # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::padx { } # ------------------------------------------------------------------ # OPTION -pady # # menubutton # ------------------------------------------------------------------ configbody iwidgets::Menubar::pady { } # ------------------------------------------------------------------ # OPTION -wraplength # # menubutton # ------------------------------------------------------------------ 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. # # ------------------------------------------------------------------ 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 {}. # # ------------------------------------------------------------------ configbody iwidgets::Menubar::helpvariable { if {"" != $itk_option(-helpvariable) && ![string match ::* $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). # # ------------------------------------------------------------- body iwidgets::Menubar::add { type path args } { if { $type != "menubutton" && \ $type != "command" && \ $type != "cascade" && \ $type != "separator" && \ $type != "radiobutton" && \ $type != "checkbutton" } { error "bad type \"$type\": must be one of the following:\ \"command\", \"checkbutton\", \"radiobutton\",\ \"separator\", \"cascacde\", or \"menubutton\"" } regsub {.*[.]} $path "" segName if { $segName == "menu" || $segName == "last" || $segName == "end" || \ [regexp {^[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) return [eval "_addMenuButton $segName $args"] # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # Or add an entry # ''''''''''''''''''''''''''''''''''''''''''''''''''''' } else { return [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. # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- body iwidgets::Menubar::insert { beforeComponent type name args } { if { $type != "menubutton" && \ $type != "command" && \ $type != "cascade" && \ $type != "separator" && \ $type != "radiobutton" && \ $type != "checkbutton" } { error "bad type \"$type\": must be one of the following:\ \"command\", \"checkbutton\", \"radiobutton\",\ \"separator\", \"cascacde\", or \"menubutton\"" } if { $name == "menu" || $name == "last" || $name == "end" || \ [regexp {^[0-9]+$} $name] } { 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" } { return [eval _insertMenuButton $beforeComponent $name $args] } else { return [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. # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- body iwidgets::Menubar::menucget { args } { return [lindex [eval menuconfigure $args] 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. # # ------------------------------------------------------------- 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] } { return [eval "_configureMenuEntry $path $tkPathOrIndex $args"] # Case: Menu (button and pane) being configured. # ''''''''''''''''''''''''''''''''''''''''''''''''''''' } else { set result [eval _configureMenu $path $tkPathOrIndex $args] return $result } } # ------------------------------------------------------------- # # METHOD: path # # SYNOPIS: path ?? # # 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. # # ------------------------------------------------------------- body iwidgets::Menubar::path { args } { set len [llength $args] if { $len < 1 || $len > 2 } { error "wrong # args: should be \ \"$itk_component(hull) path ?mode?> \"" } 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. # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- 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 # ------------------------------------------------------------- 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) # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- body iwidgets::Menubar::command { cmdName args } { eval "add command $_ourMenuPath.$cmdName $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. # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- 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 # # ------------------------------------------------------------- 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 # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- body iwidgets::Menubar::_makeMenuButton {buttonName args} { set menuEvalStr {} #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # Capture the -menu option if present # ''''''''''''''''''''''''''''''''''' # does the -menu switch exist in the args list?? if { [regexp -- {-menu} $args] } { # Make a menu Option set menuOpt [iwidgets::MenuOption #auto] # set the -menu value (if present in args) eval "$menuOpt set $args" set menuEvalStr [$menuOpt cget -value] # add the -menu option to our options list (attach to menu) lappend _options(.$buttonName) $menuOpt } # attach the menu to the menubutton's arg list lappend args -menu $itk_component(menubar).$buttonName.menu #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # 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) #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # Adjust for Help Menus # '''''''''''''''''''''''''''''''' if { $buttonName == "help" } { pack $itk_component($buttonName) -side right } else { pack $itk_component($buttonName) -side left } _makeMenu $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) # # ------------------------------------------------------------- body iwidgets::Menubar::_makeMenu { buttonName menuEvalStr } { #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # Create menu component # '''''''''''''''''''''''''''''''' itk_component add $buttonName-menu { ::menu $itk_component($buttonName).menu } { keep \ -activebackground \ -activeborderwidth \ -activeforeground \ -background \ -borderwidth \ -cursor \ -disabledforeground \ -font \ -foreground } set _pathMap(.$buttonName.menu) $itk_component($buttonName-menu) #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # Attach help handler to this menu # '''''''''''''''''''''''''''''''' #bind $itk_component($buttonName-menu) \ [code $this _helpHandler $itk_component(hull).$buttonName.menu %y] bind $itk_component($buttonName-menu) \ [code $this _helpHandler .$buttonName.menu %y] #bind $itk_component($buttonName-menu) \ "+[code $this _leaveHandler $itk_component(hull).$buttonName.menu]" bind $itk_component($buttonName-menu) \ "+[code $this _leaveHandler .$buttonName.menu]" #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # Handle -menu #''''''''''''''''''''''''''''''''' set _ourMenuPath .$buttonName set _tkMenuPath $itk_component($buttonName-menu) # # 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] _substEvalStr menuEvalStr } # # 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 # # ------------------------------------------------------------- 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. # ------------------------------------------------------------- body iwidgets::Menubar::_deleteMenu { args } { set len [llength $args] switch -- $len { 1 { # get a corrected path (subst for number, last, end) set path [_parsePath [lindex $args 0]] _deleteAMenu $path } 2 { # 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 [lindex $args 0]] regsub {[.]menu$} $menuStartPath "" menuStartPath set menuEndPath [_parsePath [lindex $args 1]] 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 } } default { } } } # ------------------------------------------------------------- # # PRIVATE METHOD: _deleteAMenu # # _deleteMenu menuPath # # deletes a single Menu (menubutton and menu pane with entries) # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- body iwidgets::Menubar::_addEntry { type path args } { # Error Checking # '''''''''''''' # the path should not end with '.menu' 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" } # ... Store -helpstr value and strip out -helpstr value from args # create a helpstr option set hs [iwidgets::HelpStrOption #auto] # set the -value switch from an args list eval "$hs set $args" # add the helpstr option to our options list (attach to entry) lappend _options($path) $hs # Handle CASCADE # '''''''''''''' # if this is a cascade go ahead and add in the menu... if { [string match cascade $type] } { # Catch addCascade errors if { [ catch {eval "_addCascade $tkMenuPath $path $args"} errMsg]} { # delete $hs: @@ 2.0 #delete $hs # remove $hs from _options($path) set lastIndex [expr [llength $_options($path)]-1] lreplace $_options($path) $lastIndex $lastIndex "" error $errMsg } # Handle Non-CASCADE # '''''''''''''''''' } else { # add the entry if { [ catch {eval "$tkMenuPath add $type $args"} errMsg] } { # delete $hs: @@ 2.0 #delete $hs # remove $hs from _options($path) set lastIndex [expr [llength $_options($path)]-1] lreplace $_options($path) $lastIndex $lastIndex "" error $errMsg } else { # update our pathmap set _pathMap($path) [_getPdIndex $tkMenuPath end] } } return $_pathMap($path) } # ------------------------------------------------------------- # # PRIVATE METHOD: _addCascade # # Creates a cascade button. Handles the -menu option # # ------------------------------------------------------------- body iwidgets::Menubar::_addCascade { tkMenuPath path args } { set menuEvalStr {} # get the cascade name from our path regsub {.*[.]} $path "" cascadeName #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # Capture the -menu option if present # ''''''''''''''''''''''''''''''''''' # does the -menu switch exist in the args list?? if { [regexp -- {-menu} $args] } { # Make a menu Option set menuOpt [iwidgets::MenuOption #auto] # set the -menu value (if present in args) eval "$menuOpt set $args" set menuEvalStr [$menuOpt cget -value] # add the -menu option to our options list (attach to menu) lappend _options($path) $menuOpt } # attach the menu pane lappend args -menu $tkMenuPath.$cascadeName # Catch error on adding cascade (could be bad option list, etc.) if { [ catch {eval "$tkMenuPath add cascade $args"} errMsg ] } { # if we appended $menuOpt, then remove it from _options if { [info exists menuOpt] } { # delete menuOpt, if it exists. ( @@ fix for 2.0 ) #delete $menuOpt set lastIndex [expr [llength $_options($path)]-1] lreplace $_options($path) $lastIndex $lastIndex "" } # signal error (for catching above) error $errMsg } # update our pathmap set _pathMap($path) [_getPdIndex $tkMenuPath end] regsub {[.][^.]*$} $path "" cascadePrefix _makeCascadeMenu $tkMenuPath $cascadePrefix $cascadeName $menuEvalStr #return $itk_component($cascadeName) } # ------------------------------------------------------------- # # PRIVATE METHOD: _makeCascadeMenu # # Creates a menu. # It then evaluates the $menuEvalStr to create entries on the menu. # # ------------------------------------------------------------- body iwidgets::Menubar::_makeCascadeMenu { tkMenuPath parentPath cascadeName menuEvalStr } { #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # Create menu component # '''''''''''''''''''''''''''''''' itk_component add $cascadeName-menu { ::menu $tkMenuPath.$cascadeName } { keep \ -activebackground \ -activeborderwidth \ -activeforeground \ -background \ -borderwidth \ -cursor \ -disabledforeground \ -font \ -foreground } set _pathMap($parentPath.$cascadeName.menu) \ $itk_component($cascadeName-menu) #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # Attach help handler to this menu # '''''''''''''''''''''''''''''''' bind $itk_component($cascadeName-menu) \ [code $this _helpHandler $parentPath.$cascadeName.menu %y] bind $itk_component($cascadeName-menu) \ "+[code $this _leaveHandler $parentPath.$cascadeName.menu]" #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # Handle -menu #''''''''''''''''''''''''''''''''' set _ourMenuPath $parentPath.$cascadeName set _tkMenuPath $itk_component($cascadeName-menu) # # 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] _substEvalStr menuEvalStr } # # 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: _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. # # ------------------------------------------------------------- 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) # 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] } # ... Store -helpstr value and strip out -helpstr value from args # create a helpstr option set hs [iwidgets::HelpStrOption #auto] # set the -value switch from an args list eval "$hs set $args" 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) lappend _options($path) $hs # 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 # # ------------------------------------------------------------- body iwidgets::Menubar::_insertCascade { bfIndex tkMenuPath path args } { set menuEvalStr {} # get the cascade name from our path regsub {.*[.]} $path "" cascadeName #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, # Capture the -menu option if present # ''''''''''''''''''''''''''''''''''' # does the -menu switch exist in the args list?? if { [regexp -- {-menu} $args] } { # Make a menu Option set menuOpt [iwidgets::MenuOption #auto] # set the -menu value (if present in args) eval "$menuOpt set $args" set menuEvalStr [$menuOpt cget -value] # add the -menu option to our options list (attach to menu) lappend _options($path) $menuOpt } # attach the menu pane lappend args -menu $tkMenuPath.$cascadeName # 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 regsub {[.][^.]*$} $path "" cascadePrefix _makeCascadeMenu $tkMenuPath $cascadePrefix $cascadeName $menuEvalStr #return $itk_component($cascadeName) } # ------------------------------------------------------------- # # PRIVATE METHOD: _deleteEntry # # _deleteEntry entryPath ?entryPath2? # # either # deletes the entry entryPath # or # deletes the entries from entryPath to entryPath2 # # ------------------------------------------------------------- body iwidgets::Menubar::_deleteEntry { args } { set len [llength $args] switch $len { 1 { # get a corrected path (subst for number, last, end) set path [_parsePath [lindex $args 0]] set entryIndex $_pathMap($path) if { $entryIndex == -1 } { error "bad value for pathName: \ [lindex $args 0] 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 } } 2 { # get a corrected path (subst for number, last, end) set path1 [_parsePath [lindex $args 0]] set path2 [_parsePath [lindex $args 1]] set fromEntryIndex $_pathMap($path1) if { $fromEntryIndex == -1 } { error "bad value for entryPath1: \ [lindex $args 0] in call to delet" } set toEntryIndex $_pathMap($path2) if { $toEntryIndex == -1 } { error "bad value for entryPath2: \ [lindex $args 1] 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] } default { error "wrong # args: should be \ \"$itk_component(hull) delete pathName ?pathName2?\"" } } } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # 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 # # ------------------------------------------------------------- body iwidgets::Menubar::_configureMenu { path tkPath args } { set class [winfo class $tkPath] set len [llength $args] switch $len { 0 { set configList [$tkPath configure] if { ! [catch {set _options($path)} ] } { foreach option $_options($path) { lappend configList [$option get] } } return $configList } 1 { # ... a get of one config item if { ! [catch {set _options($path)} ] } { foreach option $_options($path) { set val [$option get $args] if { $val != {} } { return $val } } } # ... OTHERWISE, let Tk get it. return [eval "$tkPath configure $args"] } default { # 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 # # ------------------------------------------------------------- body iwidgets::Menubar::_configureMenuOption { type path args } { regsub {[.][^.]*$} $path "" pathPrefix if { $type == "menubutton" } { set menuList [_getMenuList] set pos [lsearch $menuList $path] if { $pos == [expr [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 # # ------------------------------------------------------------- body iwidgets::Menubar::_configureMenuEntry { path index args } { set type [type $path] set len [llength $args] # get the menu path from the entry path name set tkMenuPath [_entryPathToTkMenuPath $path] switch $len { 0 { set configList [$tkMenuPath entryconfigure \ [_getTkIndex $tkMenuPath $index]] if { ! [catch {set _options($path)} ] } { foreach option $_options($path) { lappend configList [$option get] } } return $configList } 1 { # ... a get of one config item if { ! [catch {set _options($path)} ] } { foreach option $_options($path) { set val [$option get $args] if { $val != {} } { return $val } } } # ... OTHERWISE, let Tk get it. return [eval $tkMenuPath entryconfigure \ [_getTkIndex $tkMenuPath $index] $args] } default { # ... Store -helpstr val,strip out -helpstr val from args # list of options for this widget foreach option $_options($path) { if { [$option cget -switch] == "-helpstr" } { eval "$option set $args" } } if { $type == "cascade" && [regexp -- {-menu} $args] } { 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 # # ------------------------------------------------------------- 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 # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- 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 # # ------------------------------------------------------------- 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 # # ------------------------------------------------------------- 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. # # ------------------------------------------------------------- body iwidgets::Menubar::_parsePath { path } { set segments [split $path .] set concatPath "" foreach seg $segments { if {$seg == ""} { continue } set concatPath $concatPath.$seg set concatPath [_getSymbolicPath $concatPath] 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. # # ------------------------------------------------------------- body iwidgets::Menubar::_getSymbolicPath { path } { # get the last segment name of the path name regsub {.*[.]} $path "" segment set returnPath $path # if the segment is a number, then look it up positionally # MATCH numeric index if { [regexp {^[0-9]+$} $segment] } { # get the parent prefix regsub {[.][^.]*$} $path "" parent # if we have no parent, then we area menubutton if { $parent == {} } { set menuList [_getMenuList] set returnPath [lindex $menuList $segment] } else { set entryList [_getEntryList $parent.menu] set returnPath [lindex $entryList $segment] } # MATCH 'end' or 'last' keywords. } elseif { [string match end $segment] || \ [string match last $segment]} { # get the parent prefix regsub {[.][^.]*$} $path "" parent # if we have no parent, then we area menubutton if { $parent == {} } { set menuList [_getMenuList] set returnPath [lindex $menuList [expr [llength $menuList] - 1]] } else { set entryList [_getEntryList $parent.menu] set returnPath [lindex $entryList [expr [llength $entryList] - 1]] } } return $returnPath } # ------------------------------------------------------------- # # PROTECTED METHOD: _leaveHandler # # Bound to the event on a menu pane. This clears the # status widget help area and resets the help entry. # # ------------------------------------------------------------- body iwidgets::Menubar::_leaveHandler { menuPath } { if { $itk_option(-helpvariable) == {} } { return } set $itk_option(-helpvariable) {} set _entryIndex -1 } # ------------------------------------------------------------- # # PROTECTED METHOD: _helpHandler # # Bound to the 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. # # ------------------------------------------------------------- body iwidgets::Menubar::_helpHandler { menuPath menuY } { if { $itk_option(-helpvariable) == {} } { return } set tkMenuWidget $_pathMap($menuPath) set entryIndex [$tkMenuWidget index @$menuY] # already on this item? if { $entryIndex == $_entryIndex } { return } set _entryIndex $entryIndex set entries [_getEntryList $menuPath] set menuEntryHit \ [lindex $entries [_getPdIndex $tkMenuWidget $entryIndex]] # helpvariable set for our Menubar? if { $itk_option(-helpvariable) != {} } { # blank out the old one set $itk_option(-helpvariable) {} # if there are options for this entry if { ! [catch {set _options($menuEntryHit)} ] } { foreach option $_options($menuEntryHit) { # if we find the -helpstr option for this widget. set args "-helpstr" if { [string match [$option cget -switch] $args] } { set val [lindex [$option get $args] 4] if { $val != {} } { set $itk_option(-helpvariable) $val } } } } } } # ------------------------------------------------------------- # # 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. # # ------------------------------------------------------------- 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 }