diff options
Diffstat (limited to 'iwidgets/generic/menubar.itk')
| -rw-r--r-- | iwidgets/generic/menubar.itk | 2267 |
1 files changed, 2267 insertions, 0 deletions
diff --git a/iwidgets/generic/menubar.itk b/iwidgets/generic/menubar.itk new file mode 100644 index 00000000000..ca2d2001075 --- /dev/null +++ b/iwidgets/generic/menubar.itk @@ -0,0 +1,2267 @@ +# +# 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$ +# ---------------------------------------------------------------------- +# 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 {} +} |