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