1# 2# Menubar widget 3# ---------------------------------------------------------------------- 4# The Menubar command creates a new window (given by the pathName 5# argument) and makes it into a Pull down menu widget. Additional 6# options, described above may be specified on the command line or 7# in the option database to configure aspects of the Menubar such 8# as its colors and font. The Menubar command returns its pathName 9# argument. At the time this command is invoked, there must not exist 10# a window named pathName, but pathName's parent must exist. 11# 12# A Menubar is a widget that simplifies the task of creating 13# menu hierarchies. It encapsulates a frame widget, as well 14# as menubuttons, menus, and menu entries. The Menubar allows 15# menus to be specified and refer enced in a more consistent 16# manner than using Tk to build menus directly. First, Menubar 17# allows a menu tree to be expressed in a hierachical "language". 18# The Menubar accepts a menuButtons option that allows a list of 19# menubuttons to be added to the Menubar. In turn, each menubutton 20# accepts a menu option that spec ifies a list of menu entries 21# to be added to the menubutton's menu (as well as an option 22# set for the menu). Cascade entries in turn, accept a menu 23# option that specifies a list of menu entries to be added to 24# the cascade's menu (as well as an option set for the menu). In 25# this manner, a complete menu grammar can be expressed to the 26# Menubar. Additionally, the Menubar allows each component of 27# the Menubar system to be referenced by a simple componentPathName 28# syntax. Finally, the Menubar extends the option set of menu 29# entries to include the helpStr option used to implement status 30# bar help. 31# 32# WISH LIST: 33# This section lists possible future enhancements. 34# 35# ---------------------------------------------------------------------- 36# AUTHOR: Bill W. Scott 37# 38# CURRENT MAINTAINER: Chad Smith --> csmith@adc.com or itclguy@yahoo.com 39# 40# @(#) $Id: menubar.itk,v 1.8 2001/08/15 18:33:13 smithc Exp $ 41# ---------------------------------------------------------------------- 42# Copyright (c) 1995 DSC Technologies Corporation 43# ====================================================================== 44# Permission to use, copy, modify, distribute and license this software 45# and its documentation for any purpose, and without fee or written 46# agreement with DSC, is hereby granted, provided that the above copyright 47# notice appears in all copies and that both the copyright notice and 48# warranty disclaimer below appear in supporting documentation, and that 49# the names of DSC Technologies Corporation or DSC Communications 50# Corporation not be used in advertising or publicity pertaining to the 51# software without specific, written prior permission. 52# 53# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING 54# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, AND NON- 55# INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE 56# AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, 57# SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. IN NO EVENT SHALL 58# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR 59# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, 60# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, 61# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 62# SOFTWARE. 63# ====================================================================== 64 65 66# 67# Usual options. 68# 69itk::usual Menubar { 70 keep -activebackground -activeborderwidth -activeforeground \ 71 -anchor -background -borderwidth -cursor -disabledforeground \ 72 -font -foreground -highlightbackground -highlightthickness \ 73 -highlightcolor -justify -padx -pady -wraplength 74} 75 76itcl::class iwidgets::Menubar { 77 inherit itk::Widget 78 79 constructor { args } {} 80 81 itk_option define -foreground foreground Foreground Black 82 itk_option define -activebackground activeBackground Foreground "#ececec" 83 itk_option define -activeborderwidth activeBorderWidth BorderWidth 2 84 itk_option define -activeforeground activeForeground Background black 85 itk_option define -anchor anchor Anchor center 86 itk_option define -borderwidth borderWidth BorderWidth 2 87 itk_option define \ 88 -disabledforeground disabledForeground DisabledForeground #a3a3a3 89 itk_option define \ 90 -font font Font "-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*" 91 itk_option define \ 92 -highlightbackground highlightBackground HighlightBackground #d9d9d9 93 itk_option define -highlightcolor highlightColor HighlightColor Black 94 itk_option define \ 95 -highlightthickness highlightThickness HighlightThickness 0 96 itk_option define -justify justify Justify center 97 itk_option define -padx padX Pad 4p 98 itk_option define -pady padY Pad 3p 99 itk_option define -wraplength wrapLength WrapLength 0 100 itk_option define -menubuttons menuButtons MenuButtons {} 101 itk_option define -helpvariable helpVariable HelpVariable {} 102 103 public { 104 method add { type path args } { } 105 method delete { args } { } 106 method index { path } { } 107 method insert { beforeComponent type name args } 108 method invoke { entryPath } { } 109 method menucget { args } { } 110 method menuconfigure { path args } { } 111 method path { args } { } 112 method type { path } { } 113 method yposition { entryPath } { } 114 } 115 116 private { 117 method menubutton { menuName args } { } 118 method options { args } { } 119 method command { cmdName args } { } 120 method checkbutton { chkName args } { } 121 method radiobutton { radName args } { } 122 method separator { sepName args } { } 123 method cascade { casName args } { } 124 method _helpHandler { menuPath } { } 125 method _addMenuButton { buttonName args} { } 126 method _insertMenuButton { beforeMenuPath buttonName args} { } 127 method _makeMenuButton {buttonName args} { } 128 method _makeMenu \ 129 { componentName widgetName menuPath menuEvalStr } { } 130 method _substEvalStr { evalStr } { } 131 method _deleteMenu { menuPath {menuPath2 {}} } { } 132 method _deleteAMenu { path } { } 133 method _addEntry { type path args } { } 134 method _addCascade { tkMenuPath path args } { } 135 method _insertEntry { beforeEntryPath type name args } { } 136 method _insertCascade { bfIndex tkMenuPath path args } { } 137 method _deleteEntry { entryPath {entryPath2 {}} } { } 138 method _configureMenu { path tkPath {option {}} args } { } 139 method _configureMenuOption { type path args } { } 140 method _configureMenuEntry { path index {option {}} args } { } 141 method _unsetPaths { parent } { } 142 method _entryPathToTkMenuPath {entryPath} { } 143 method _getTkIndex { tkMenuPath tkIndex} { } 144 method _getPdIndex { tkMenuPath tkIndex } { } 145 method _getMenuList { } { } 146 method _getEntryList { menu } { } 147 method _parsePath { path } { } 148 method _getSymbolicPath { parent segment } { } 149 method _getCallerLevel { } 150 151 variable _parseLevel 0 ;# The parse level depth 152 variable _callerLevel #0 ;# abs level of caller 153 variable _pathMap ;# Array indexed by Menubar's path 154 ;# naming, yields tk menu path 155 variable _entryIndex -1 ;# current entry help is displayed 156 ;# for during help <motion> events 157 158 variable _tkMenuPath ;# last tk menu being added to 159 variable _ourMenuPath ;# our last valid path constructed. 160 161 variable _menuOption ;# The -menu option 162 variable _helpString ;# The -helpstr optio 163 } 164} 165 166# 167# Use option database to override default resources. 168# 169option add *Menubar*Menu*tearOff false widgetDefault 170option add *Menubar*Menubutton*relief flat widgetDefault 171option add *Menubar*Menu*relief raised widgetDefault 172 173# 174# Provide a lowercase access method for the menubar class 175# 176proc ::iwidgets::menubar { args } { 177 uplevel ::iwidgets::Menubar $args 178} 179 180# ------------------------------------------------------------------ 181# CONSTRUCTOR 182# ------------------------------------------------------------------ 183itcl::body iwidgets::Menubar::constructor { args } { 184 component hull configure -borderwidth 0 185 186 # 187 # Create the Menubar Frame that will hold the menus. 188 # 189 # might want to make -relief and -bd options with defaults 190 itk_component add menubar { 191 frame $itk_interior.menubar -relief raised -bd 2 192 } { 193 keep -cursor -background -width -height 194 } 195 pack $itk_component(menubar) -fill both -expand yes 196 197 # Map our pathname to class to the actual menubar frame 198 set _pathMap(.) $itk_component(menubar) 199 200 eval itk_initialize $args 201 202 # 203 # HACK HACK HACK 204 # Tk expects some variables to be defined and due to some 205 # unknown reason we confuse its normal ordering. So, if 206 # the user creates a menubutton with no menu it will fail 207 # when clicked on with a "Error: can't read $tkPriv(oldGrab): 208 # no such element in array". So by setting it to null we 209 # avoid this error. 210 uplevel #0 "set tkPriv(oldGrab) {}" 211 212} 213 214# ------------------------------------------------------------------ 215# OPTIONS 216# ------------------------------------------------------------------ 217# This first set of options are for configuring menus and/or menubuttons 218# at the menu level. 219# 220# ------------------------------------------------------------------ 221# OPTION -foreground 222# 223# menu 224# menubutton 225# ------------------------------------------------------------------ 226itcl::configbody iwidgets::Menubar::foreground { 227} 228 229# ------------------------------------------------------------------ 230# OPTION -activebackground 231# 232# menu 233# menubutton 234# ------------------------------------------------------------------ 235itcl::configbody iwidgets::Menubar::activebackground { 236} 237 238# ------------------------------------------------------------------ 239# OPTION -activeborderwidth 240# 241# menu 242# ------------------------------------------------------------------ 243itcl::configbody iwidgets::Menubar::activeborderwidth { 244} 245 246# ------------------------------------------------------------------ 247# OPTION -activeforeground 248# 249# menu 250# menubutton 251# ------------------------------------------------------------------ 252itcl::configbody iwidgets::Menubar::activeforeground { 253} 254 255# ------------------------------------------------------------------ 256# OPTION -anchor 257# 258# menubutton 259# ------------------------------------------------------------------ 260itcl::configbody iwidgets::Menubar::anchor { 261} 262 263# ------------------------------------------------------------------ 264# OPTION -borderwidth 265# 266# menu 267# menubutton 268# ------------------------------------------------------------------ 269itcl::configbody iwidgets::Menubar::borderwidth { 270} 271 272# ------------------------------------------------------------------ 273# OPTION -disabledforeground 274# 275# menu 276# menubutton 277# ------------------------------------------------------------------ 278itcl::configbody iwidgets::Menubar::disabledforeground { 279} 280 281# ------------------------------------------------------------------ 282# OPTION -font 283# 284# menu 285# menubutton 286# ------------------------------------------------------------------ 287itcl::configbody iwidgets::Menubar::font { 288} 289 290# ------------------------------------------------------------------ 291# OPTION -highlightbackground 292# 293# menubutton 294# ------------------------------------------------------------------ 295itcl::configbody iwidgets::Menubar::highlightbackground { 296} 297 298# ------------------------------------------------------------------ 299# OPTION -highlightcolor 300# 301# menubutton 302# ------------------------------------------------------------------ 303itcl::configbody iwidgets::Menubar::highlightcolor { 304} 305 306# ------------------------------------------------------------------ 307# OPTION -highlightthickness 308# 309# menubutton 310# ------------------------------------------------------------------ 311itcl::configbody iwidgets::Menubar::highlightthickness { 312} 313 314# ------------------------------------------------------------------ 315# OPTION -justify 316# 317# menubutton 318# ------------------------------------------------------------------ 319itcl::configbody iwidgets::Menubar::justify { 320} 321 322# ------------------------------------------------------------------ 323# OPTION -padx 324# 325# menubutton 326# ------------------------------------------------------------------ 327itcl::configbody iwidgets::Menubar::padx { 328} 329 330# ------------------------------------------------------------------ 331# OPTION -pady 332# 333# menubutton 334# ------------------------------------------------------------------ 335itcl::configbody iwidgets::Menubar::pady { 336} 337 338# ------------------------------------------------------------------ 339# OPTION -wraplength 340# 341# menubutton 342# ------------------------------------------------------------------ 343itcl::configbody iwidgets::Menubar::wraplength { 344} 345 346# ------------------------------------------------------------------ 347# OPTION -menubuttons 348# 349# The menuButton option is a string which specifies the arrangement 350# of menubuttons on the Menubar frame. Each menubutton entry is 351# delimited by the newline character. Each entry is treated as 352# an add command to the Menubar. 353# 354# ------------------------------------------------------------------ 355itcl::configbody iwidgets::Menubar::menubuttons { 356 if { $itk_option(-menubuttons) != {} } { 357 358 # IF one exists already, delete the old one and create 359 # a new one 360 if { ! [catch {_parsePath .0}] } { 361 delete .0 .last 362 } 363 364 # 365 # Determine the context level to evaluate the option string at 366 # 367 set _callerLevel [_getCallerLevel] 368 369 # 370 # Parse the option string in their scope, then execute it in 371 # our scope. 372 # 373 incr _parseLevel 374 _substEvalStr itk_option(-menubuttons) 375 eval $itk_option(-menubuttons) 376 377 # reset so that we know we aren't parsing in a scope currently. 378 incr _parseLevel -1 379 } 380} 381 382# ------------------------------------------------------------------ 383# OPTION -helpvariable 384# 385# Specifies the global variable to update whenever the mouse is in 386# motion over a menu entry. This global variable is updated with the 387# current value of the active menu entry's helpStr. Other widgets 388# can "watch" this variable with the trace command, or as is the 389# case with entry or label widgets, they can set their textVariable 390# to the same global variable. This allows for a simple implementation 391# of a help status bar. Whenever the mouse leaves a menu entry, 392# the helpVariable is set to the empty string {}. 393# ------------------------------------------------------------------ 394itcl::configbody iwidgets::Menubar::helpvariable { 395 if {"" != $itk_option(-helpvariable) && 396 ![string match ::* $itk_option(-helpvariable)] && 397 ![string match @itcl* $itk_option(-helpvariable)]} { 398 set itk_option(-helpvariable) "::$itk_option(-helpvariable)" 399 } 400} 401 402 403# ------------------------------------------------------------- 404# 405# METHOD: add type path args 406# 407# Adds either a menu to the menu bar or a menu entry to a 408# menu pane. 409# 410# If the type is one of cascade, checkbutton, command, 411# radiobutton, or separator it adds a new entry to the bottom 412# of the menu denoted by the menuPath prefix of componentPath- 413# Name. The new entry's type is given by type. If additional 414# arguments are present, they specify options available to 415# component type Entry. See the man pages for menu(n) in the 416# section on Entries. In addition all entries accept an added 417# option, helpStr: 418# 419# -helpstr value 420# 421# Specifes the string to associate with the entry. 422# When the mouse moves over the associated entry, the variable 423# denoted by helpVariable is set. Another widget can bind to 424# the helpVariable and thus display status help. 425# 426# If the type is menubutton, it adds a new menubut- 427# ton to the menu bar. If additional arguments are present, 428# they specify options available to component type MenuButton. 429# 430# If the type is menubutton or cascade, the menu 431# option is available in addition to normal Tk options for 432# these to types. 433# 434# -menu menuSpec 435# 436# This is only valid for componentPathNames of type 437# menubutton or cascade. Specifes an option set and/or a set 438# of entries to place on a menu and associate with the menu- 439# button or cascade. The option keyword allows the menu widget 440# to be configured. Each item in the menuSpec is treated as 441# add commands (each with the possibility of having other 442# -menu options). In this way a menu can be recursively built. 443# 444# The last segment of componentPathName cannot be 445# one of the keywords last, menu, end. Additionally, it may 446# not be a number. However the componentPathName may be refer- 447# enced in this manner (see discussion of Component Path 448# Names). 449# 450# ------------------------------------------------------------- 451itcl::body iwidgets::Menubar::add { type path args } { 452 if ![regexp \ 453 {^(menubutton|command|cascade|separator|radiobutton|checkbutton)$} \ 454 $type] { 455 error "bad type \"$type\": must be one of the following:\ 456 \"command\", \"checkbutton\", \"radiobutton\",\ 457 \"separator\", \"cascade\", or \"menubutton\"" 458 } 459 regexp {[^.]+$} $path segName 460 if [regexp {^(menu|last|end|[0-9]+)$} $segName] { 461 error "bad name \"$segName\": user created component \ 462 path names may not end with \ 463 \"end\", \"last\", \"menu\", \ 464 or be an integer" 465 } 466 467 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 468 # OK, either add a menu 469 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 470 if { $type == "menubutton" } { 471 # grab the last component name (the menu name) 472 eval _addMenuButton $segName $args 473 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 474 # Or add an entry 475 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 476 } else { 477 eval _addEntry $type $path $args 478 } 479} 480 481 482# ------------------------------------------------------------- 483# 484# METHOD: delete entryPath ?entryPath2? 485# 486# If componentPathName is of component type MenuButton or 487# Menu, delete operates on menus. If componentPathName is of 488# component type Entry, delete operates on menu entries. 489# 490# This command deletes all components between com- 491# ponentPathName and componentPathName2 inclusive. If com- 492# ponentPathName2 is omitted then it defaults to com- 493# ponentPathName. Returns an empty string. 494# 495# If componentPathName is of type Menubar, then all menus 496# and the menu bar frame will be destroyed. In this case com- 497# ponentPathName2 is ignored. 498# 499# ------------------------------------------------------------- 500itcl::body iwidgets::Menubar::delete { args } { 501 502 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 503 # Handle out of bounds in arg lengths 504 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 505 if { [llength $args] > 0 && [llength $args] <=2 } { 506 507 # Path Conversions 508 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 509 set path [_parsePath [lindex $args 0]] 510 511 set pathOrIndex $_pathMap($path) 512 513 # Menu Entry 514 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 515 if { [regexp {^[0-9]+$} $pathOrIndex] } { 516 eval "_deleteEntry $args" 517 518 # Menu 519 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 520 } else { 521 eval "_deleteMenu $args" 522 } 523 } else { 524 error "wrong # args: should be \ 525 \"$itk_component(hull) delete pathName ?pathName2?\"" 526 } 527 return "" 528} 529 530# ------------------------------------------------------------- 531# 532# METHOD: index path 533# 534# If componentPathName is of type menubutton or menu, it 535# returns the position of the menu/menubutton on the Menubar 536# frame. 537# 538# If componentPathName is of type command, separator, 539# radiobutton, checkbutton, or cascade, it returns the menu 540# widget's numerical index for the entry corresponding to com- 541# ponentPathName. If path is not found or the Menubar frame is 542# passed in, -1 is returned. 543# 544# ------------------------------------------------------------- 545itcl::body iwidgets::Menubar::index { path } { 546 547 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 548 # Path conversions 549 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 550 if { [catch {set fullPath [_parsePath $path]} ] } { 551 return -1 552 } 553 if { [catch {set tkPathOrIndex $_pathMap($fullPath)} ] } { 554 return -1 555 } 556 557 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 558 # If integer, return the value, otherwise look up the menu position 559 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 560 if { [regexp {^[0-9]+$} $tkPathOrIndex] } { 561 set index $tkPathOrIndex 562 } else { 563 set index [lsearch [_getMenuList] $fullPath] 564 } 565 566 return $index 567} 568 569# ------------------------------------------------------------- 570# 571# METHOD: insert beforeComponent type name ?option value? 572# 573# Insert a new component named name before the component 574# specified by componentPathName. 575# 576# If componentPathName is of type MenuButton or Menu, the 577# new component inserted is of type Menu and given the name 578# name. In this case valid option value pairs are those 579# accepted by menubuttons. 580# 581# If componentPathName is of type Entry, the new com- 582# ponent inserted is of type Entry and given the name name. In 583# this case valid option value pairs are those accepted by 584# menu entries. 585# 586# name cannot be one of the keywords last, menu, end. 587# dditionally, it may not be a number. However the com- 588# ponentPathName may be referenced in this manner (see discus- 589# sion of Component Path Names). 590# 591# Returns -1 if the menubar frame is passed in. 592# 593# ------------------------------------------------------------- 594itcl::body iwidgets::Menubar::insert { beforeComponent type name args } { 595 if ![regexp \ 596 {^(menubutton|command|cascade|separator|radiobutton|checkbutton)$} \ 597 $type] { 598 error "bad type \"$type\": must be one of the following:\ 599 \"command\", \"checkbutton\", \"radiobutton\",\ 600 \"separator\", \"cascade\", or \"menubutton\"" 601 } 602 regexp {[^.]+$} $name segName 603 if [regexp {^(menu|last|end|[0-9]+)$} $segName] { 604 error "bad name \"$name\": user created component \ 605 path names may not end with \ 606 \"end\", \"last\", \"menu\", \ 607 or be an integer" 608 } 609 610 set beforeComponent [_parsePath $beforeComponent] 611 612 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 613 # Choose menu insertion or entry insertion 614 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 615 if { $type == "menubutton" } { 616 eval _insertMenuButton $beforeComponent $name $args 617 } else { 618 eval _insertEntry $beforeComponent $type $name $args 619 } 620} 621 622 623# ------------------------------------------------------------- 624# 625# METHOD: invoke entryPath 626# 627# Invoke the action of the menu entry denoted by 628# entryComponentPathName. See the sections on the individual 629# entries in the menu(n) man pages. If the menu entry is dis- 630# abled then nothing happens. If the entry has a command 631# associated with it then the result of that command is 632# returned as the result of the invoke widget command. Other- 633# wise the result is an empty string. 634# 635# If componentPathName is not a menu entry, an error is 636# issued. 637# 638# ------------------------------------------------------------- 639itcl::body iwidgets::Menubar::invoke { entryPath } { 640 641 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 642 # Path Conversions 643 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 644 set entryPath [_parsePath $entryPath] 645 set index $_pathMap($entryPath) 646 647 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 648 # Error Processing 649 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 650 # first verify that beforeEntryPath is actually a path to 651 # an entry and not to menu, menubutton, etc. 652 if { ! [regexp {^[0-9]+$} $index] } { 653 error "bad entry path: beforeEntryPath is not an entry" 654 } 655 656 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 657 # Call invoke command 658 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 659 # get the tk menu path to call 660 set tkMenuPath [_entryPathToTkMenuPath $entryPath] 661 662 # call the menu's invoke command, adjusting index based on tearoff 663 $tkMenuPath invoke [_getTkIndex $tkMenuPath $index] 664} 665 666# ------------------------------------------------------------- 667# 668# METHOD: menucget componentPath option 669# 670# Returns the current value of the configuration option 671# given by option. The component type of componentPathName 672# determines the valid available options. 673# 674# ------------------------------------------------------------- 675itcl::body iwidgets::Menubar::menucget { path opt } { 676 return [lindex [menuconfigure $path $opt] 4] 677} 678 679# ------------------------------------------------------------- 680# 681# METHOD: menuconfigure componentPath ?option? ?value option value...? 682# 683# Query or modify the configuration options of the sub- 684# component of the Menubar specified by componentPathName. If 685# no option is specified, returns a list describing all of the 686# available options for componentPathName (see 687# Tk_ConfigureInfo for information on the format of this 688# list). If option is specified with no value, then the com- 689# mand returns a list describing the one named option (this 690# list will be identical to the corresponding sublist of the 691# value returned if no option is specified). If one or more 692# option-value pairs are specified, then the command modifies 693# the given widget option(s) to have the given value(s); in 694# this case the command returns an empty string. The component 695# type of componentPathName determines the valid available 696# options. 697# 698# ------------------------------------------------------------- 699itcl::body iwidgets::Menubar::menuconfigure { path args } { 700 701 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 702 # Path Conversions 703 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 704 set path [_parsePath $path] 705 set tkPathOrIndex $_pathMap($path) 706 707 # Case: Menu entry being configured 708 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 709 if { [regexp {^[0-9]+$} $tkPathOrIndex] } { 710 eval "_configureMenuEntry $path $tkPathOrIndex $args" 711 712 # Case: Menu (button and pane) being configured. 713 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 714 } else { 715 eval _configureMenu $path $tkPathOrIndex $args 716 } 717} 718 719# ------------------------------------------------------------- 720# 721# METHOD: path 722# 723# SYNOPIS: path ?<mode>? <pattern> 724# 725# Returns a fully formed component path that matches pat- 726# tern. If no match is found it returns -1. The mode argument 727# indicates how the search is to be matched against pattern 728# and it must have one of the following values: 729# 730# -glob Pattern is a glob-style pattern which is 731# matched against each component path using the same rules as 732# the string match command. 733# 734# -regexp Pattern is treated as a regular expression 735# and matched against each component path using the same 736# rules as the regexp command. 737# 738# The default mode is -glob. 739# 740# ------------------------------------------------------------- 741itcl::body iwidgets::Menubar::path { args } { 742 743 set len [llength $args] 744 if { $len < 1 || $len > 2 } { 745 error "wrong # args: should be \ 746 \"$itk_component(hull) path ?mode?> <pattern>\"" 747 } 748 749 set pathList [array names _pathMap] 750 751 set len [llength $args] 752 switch -- $len { 753 1 { 754 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 755 # Case: no search modes given 756 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 757 set pattern [lindex $args 0] 758 set found [lindex $pathList [lsearch -glob $pathList $pattern]] 759 } 760 2 { 761 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 762 # Case: search modes present (-glob, -regexp) 763 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 764 set options [lindex $args 0] 765 set pattern [lindex $args 1] 766 set found \ 767 [lindex $pathList [lsearch $options $pathList $pattern]] 768 } 769 default { 770 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 771 # Case: wrong # arguments 772 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 773 error "wrong # args: \ 774 should be \"$itk_component(hull) path ?-glob? ?-regexp? pattern\"" 775 } 776 } 777 778 return $found 779} 780 781# ------------------------------------------------------------- 782# 783# METHOD: type path 784# 785# Returns the type of the component given by entryCom- 786# ponentPathName. For menu entries, this is the type argument 787# passed to the add/insert widget command when the entry was 788# created, such as command or separator. Othewise it is either 789# a menubutton or a menu. 790# 791# ------------------------------------------------------------- 792itcl::body iwidgets::Menubar::type { path } { 793 794 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 795 # Path Conversions 796 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 797 set path [_parsePath $path] 798 799 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 800 # Error Handling: does the path exist? 801 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 802 if { [catch {set index $_pathMap($path)} ] } { 803 error "bad path \"$path\"" 804 } 805 806 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 807 # ENTRY, Ask TK for type 808 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 809 if { [regexp {^[0-9]+$} $index] } { 810 # get the menu path from the entry path name 811 set tkMenuPath [_entryPathToTkMenuPath $path] 812 813 # call the menu's type command, adjusting index based on tearoff 814 set type [$tkMenuPath type [_getTkIndex $tkMenuPath $index]] 815 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 816 # MENUBUTTON, MENU, or FRAME 817 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 818 } else { 819 # should not happen, but have a path that is not a valid window. 820 if { [catch {set className [winfo class $_pathMap($path)]}] } { 821 error "serious error: \"$path\" is not a valid window" 822 } 823 # get the classname, look it up, get index, us it to look up type 824 set type [ lindex \ 825 {frame menubutton menu} \ 826 [lsearch { Frame Menubutton Menu } $className] \ 827 ] 828 } 829 return $type 830} 831 832# ------------------------------------------------------------- 833# 834# METHOD: yposition entryPath 835# 836# Returns a decimal string giving the y-coordinate within 837# the menu window of the topmost pixel in the entry specified 838# by componentPathName. If the componentPathName is not an 839# entry, an error is issued. 840# 841# ------------------------------------------------------------- 842itcl::body iwidgets::Menubar::yposition { entryPath } { 843 844 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 845 # Path Conversions 846 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 847 set entryPath [_parsePath $entryPath] 848 set index $_pathMap($entryPath) 849 850 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 851 # Error Handling 852 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 853 # first verify that entryPath is actually a path to 854 # an entry and not to menu, menubutton, etc. 855 if { ! [regexp {^[0-9]+$} $index] } { 856 error "bad value: entryPath is not an entry" 857 } 858 859 # ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 860 # Call yposition command 861 # ''''''''''''''''''''''''''''''''''''''''''''''''''''' 862 # get the menu path from the entry path name 863 set tkMenuPath [_entryPathToTkMenuPath $entryPath] 864 865 # call the menu's yposition command, adjusting index based on tearoff 866 return [$tkMenuPath yposition [_getTkIndex $tkMenuPath $index]] 867 868} 869 870# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 871# PARSING METHODS 872# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 873# ------------------------------------------------------------- 874# 875# PARSING METHOD: menubutton 876# 877# This method is invoked via an evaluation of the -menubuttons 878# option for the Menubar. 879# 880# It adds a new menubutton and processes any -menu options 881# for creating entries on the menu pane associated with the 882# menubutton 883# ------------------------------------------------------------- 884itcl::body iwidgets::Menubar::menubutton { menuName args } { 885 eval "add menubutton .$menuName $args" 886} 887 888# ------------------------------------------------------------- 889# 890# PARSING METHOD: options 891# 892# This method is invoked via an evaluation of the -menu 893# option for menubutton commands. 894# 895# It configures the current menu ($_ourMenuPath) with the options 896# that follow (args) 897# 898# ------------------------------------------------------------- 899itcl::body iwidgets::Menubar::options { args } { 900 eval "$_tkMenuPath configure $args" 901} 902 903 904# ------------------------------------------------------------- 905# 906# PARSING METHOD: command 907# 908# This method is invoked via an evaluation of the -menu 909# option for menubutton commands. 910# 911# It adds a new command entry to the current menu, $_ourMenuPath 912# naming it $cmdName. Since this is the most common case when 913# creating menus, streamline it by duplicating some code from 914# the add{} method. 915# 916# ------------------------------------------------------------- 917itcl::body iwidgets::Menubar::command { cmdName args } { 918 set path $_ourMenuPath.$cmdName 919 920 # error checking 921 regsub {.*[.]} $path "" segName 922 if [regexp {^(menu|last|end|[0-9]+)$} $segName] { 923 error "bad name \"$segName\": user created component \ 924 path names may not end with \ 925 \"end\", \"last\", \"menu\", \ 926 or be an integer" 927 } 928 929 eval _addEntry command $path $args 930} 931 932# ------------------------------------------------------------- 933# 934# PARSING METHOD: checkbutton 935# 936# This method is invoked via an evaluation of the -menu 937# option for menubutton/cascade commands. 938# 939# It adds a new checkbutton entry to the current menu, $_ourMenuPath 940# naming it $chkName. 941# 942# ------------------------------------------------------------- 943itcl::body iwidgets::Menubar::checkbutton { chkName args } { 944 eval "add checkbutton $_ourMenuPath.$chkName $args" 945} 946 947# ------------------------------------------------------------- 948# 949# PARSING METHOD: radiobutton 950# 951# This method is invoked via an evaluation of the -menu 952# option for menubutton/cascade commands. 953# 954# It adds a new radiobutton entry to the current menu, $_ourMenuPath 955# naming it $radName. 956# 957# ------------------------------------------------------------- 958itcl::body iwidgets::Menubar::radiobutton { radName args } { 959 eval "add radiobutton $_ourMenuPath.$radName $args" 960} 961 962# ------------------------------------------------------------- 963# 964# PARSING METHOD: separator 965# 966# This method is invoked via an evaluation of the -menu 967# option for menubutton/cascade commands. 968# 969# It adds a new separator entry to the current menu, $_ourMenuPath 970# naming it $sepName. 971# 972# ------------------------------------------------------------- 973itcl::body iwidgets::Menubar::separator { sepName args } { 974 eval $_tkMenuPath add separator 975 set _pathMap($_ourMenuPath.$sepName) [_getPdIndex $_tkMenuPath end] 976} 977 978# ------------------------------------------------------------- 979# 980# PARSING METHOD: cascade 981# 982# This method is invoked via an evaluation of the -menu 983# option for menubutton/cascade commands. 984# 985# It adds a new cascade entry to the current menu, $_ourMenuPath 986# naming it $casName. It processes the -menu option if present, 987# adding a new menu pane and its associated entries found. 988# 989# ------------------------------------------------------------- 990itcl::body iwidgets::Menubar::cascade { casName args } { 991 992 # Save the current menu we are adding to, cascade can change 993 # the current menu through -menu options. 994 set saveOMP $_ourMenuPath 995 set saveTKP $_tkMenuPath 996 997 eval "add cascade $_ourMenuPath.$casName $args" 998 999 # Restore the saved menu states so that the next entries of 1000 # the -menu/-menubuttons we are processing will be at correct level. 1001 set _ourMenuPath $saveOMP 1002 set _tkMenuPath $saveTKP 1003} 1004 1005# ... A P I S U P P O R T M E T H O D S... 1006 1007# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1008# MENU ADD, INSERT, DELETE 1009# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1010# ------------------------------------------------------------- 1011# 1012# PRIVATE METHOD: _addMenuButton 1013# 1014# Makes a new menubutton & associated -menu, pack appended 1015# 1016# ------------------------------------------------------------- 1017itcl::body iwidgets::Menubar::_addMenuButton { buttonName args} { 1018 1019 eval "_makeMenuButton $buttonName $args" 1020 1021 #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 1022 # Pack at end, adjust for help buttonName 1023 # '''''''''''''''''''''''''''''''''' 1024 if { $buttonName == "help" } { 1025 pack $itk_component($buttonName) -side right 1026 } else { 1027 pack $itk_component($buttonName) -side left 1028 } 1029 1030 return $itk_component($buttonName) 1031} 1032 1033# ------------------------------------------------------------- 1034# 1035# PRIVATE METHOD: _insertMenuButton 1036# 1037# inserts a menubutton named $buttonName on a menu bar before 1038# another menubutton specified by $beforeMenuPath 1039# 1040# ------------------------------------------------------------- 1041itcl::body iwidgets::Menubar::_insertMenuButton { beforeMenuPath buttonName args} { 1042 1043 eval "_makeMenuButton $buttonName $args" 1044 1045 #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 1046 # Pack before the $beforeMenuPath 1047 # '''''''''''''''''''''''''''''''' 1048 set beforeTkMenu $_pathMap($beforeMenuPath) 1049 regsub {[.]menu$} $beforeTkMenu "" beforeTkMenu 1050 pack $itk_component(menubar).$buttonName \ 1051 -side left \ 1052 -before $beforeTkMenu 1053 1054 return $itk_component($buttonName) 1055} 1056 1057# ------------------------------------------------------------- 1058# 1059# PRIVATE METHOD: _makeMenuButton 1060# 1061# creates a menubutton named buttonName on the menubar with args. 1062# The -menu option if present will trigger attaching a menu pane. 1063# 1064# ------------------------------------------------------------- 1065itcl::body iwidgets::Menubar::_makeMenuButton {buttonName args} { 1066 1067 #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 1068 # Capture the -menu option if present 1069 # ''''''''''''''''''''''''''''''''''' 1070 array set temp $args 1071 if { [::info exists temp(-menu)] } { 1072 # We only keep this in case of menuconfigure or menucget 1073 set _menuOption(.$buttonName) $temp(-menu) 1074 set menuEvalStr $temp(-menu) 1075 } else { 1076 set menuEvalStr {} 1077 } 1078 1079 # attach the actual menu widget to the menubutton's arg list 1080 set temp(-menu) $itk_component(menubar).$buttonName.menu 1081 set args [array get temp] 1082 1083 #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 1084 # Create menubutton component 1085 # '''''''''''''''''''''''''''''''' 1086 itk_component add $buttonName { 1087 eval ::menubutton \ 1088 $itk_component(menubar).$buttonName \ 1089 $args 1090 } { 1091 keep \ 1092 -activebackground \ 1093 -activeforeground \ 1094 -anchor \ 1095 -background \ 1096 -borderwidth \ 1097 -cursor \ 1098 -disabledforeground \ 1099 -font \ 1100 -foreground \ 1101 -highlightbackground \ 1102 -highlightcolor \ 1103 -highlightthickness \ 1104 -justify \ 1105 -padx \ 1106 -pady \ 1107 -wraplength 1108 } 1109 1110 set _pathMap(.$buttonName) $itk_component($buttonName) 1111 1112 _makeMenu \ 1113 $buttonName-menu \ 1114 $itk_component($buttonName).menu \ 1115 .$buttonName \ 1116 $menuEvalStr 1117 1118 return $itk_component($buttonName) 1119 1120} 1121 1122# ------------------------------------------------------------- 1123# 1124# PRIVATE METHOD: _makeMenu 1125# 1126# Creates a menu. 1127# It then evaluates the $menuEvalStr to create entries on the menu. 1128# 1129# Assumes the existence of $itk_component($buttonName) 1130# 1131# ------------------------------------------------------------- 1132itcl::body iwidgets::Menubar::_makeMenu \ 1133 { componentName widgetName menuPath menuEvalStr } { 1134 1135 #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 1136 # Create menu component 1137 # '''''''''''''''''''''''''''''''' 1138 itk_component add $componentName { 1139 ::menu $widgetName 1140 } { 1141 keep \ 1142 -activebackground \ 1143 -activeborderwidth \ 1144 -activeforeground \ 1145 -background \ 1146 -borderwidth \ 1147 -cursor \ 1148 -disabledforeground \ 1149 -font \ 1150 -foreground 1151 } 1152 1153 set _pathMap($menuPath.menu) $itk_component($componentName) 1154 1155 #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 1156 # Attach help handler to this menu 1157 # '''''''''''''''''''''''''''''''' 1158 bind $itk_component($componentName) <<MenuSelect>> \ 1159 [itcl::code $this _helpHandler $menuPath.menu] 1160 1161 #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 1162 # Handle -menu 1163 #''''''''''''''''''''''''''''''''' 1164 set _ourMenuPath $menuPath 1165 set _tkMenuPath $itk_component($componentName) 1166 1167 # 1168 # A zero parseLevel says we are at the top of the parse tree, 1169 # so get the context scope level and do a subst for the menuEvalStr. 1170 # 1171 if { $_parseLevel == 0 } { 1172 set _callerLevel [_getCallerLevel] 1173 } 1174 1175 # 1176 # bump up the parse level, so if we get called via the 'eval $menuEvalStr' 1177 # we know to skip the above steps... 1178 # 1179 incr _parseLevel 1180 eval $menuEvalStr 1181 1182 # 1183 # leaving, so done with this parse level, so bump it back down 1184 # 1185 incr _parseLevel -1 1186} 1187 1188# ------------------------------------------------------------- 1189# 1190# PRIVATE METHOD: _substEvalStr 1191# 1192# This performs the substitution and evaluation of $ [], \ found 1193# in the -menubutton/-menus options 1194# 1195# ------------------------------------------------------------- 1196itcl::body iwidgets::Menubar::_substEvalStr { evalStr } { 1197 upvar $evalStr evalStrRef 1198 set evalStrRef [uplevel $_callerLevel [list subst $evalStrRef]] 1199} 1200 1201 1202# ------------------------------------------------------------- 1203# 1204# PRIVATE METHOD: _deleteMenu 1205# 1206# _deleteMenu menuPath ?menuPath2? 1207# 1208# deletes menuPath or from menuPath to menuPath2 1209# 1210# Menu paths may be formed in one of two ways 1211# .MENUBAR.menuName where menuName is the name of the menu 1212# .MENUBAR.menuName.menu where menuName is the name of the menu 1213# 1214# The basic rule is '.menu' is not needed. 1215# ------------------------------------------------------------- 1216itcl::body iwidgets::Menubar::_deleteMenu { menuPath {menuPath2 {}} } { 1217 1218 if { $menuPath2 == "" } { 1219 # get a corrected path (subst for number, last, end) 1220 set path [_parsePath $menuPath] 1221 1222 _deleteAMenu $path 1223 1224 } else { 1225 # gets the list of menus in interface order 1226 set menuList [_getMenuList] 1227 1228 # ... get the start menu and the last menu ... 1229 1230 # get a corrected path (subst for number, last, end) 1231 set menuStartPath [_parsePath $menuPath] 1232 1233 regsub {[.]menu$} $menuStartPath "" menuStartPath 1234 1235 set menuEndPath [_parsePath $menuPath2] 1236 1237 regsub {[.]menu$} $menuEndPath "" menuEndPath 1238 1239 # get the menu position (0 based) of the start and end menus. 1240 set start [lsearch -exact $menuList $menuStartPath] 1241 if { $start == -1 } { 1242 error "bad menu path \"$menuStartPath\": \ 1243 should be one of $menuList" 1244 } 1245 set end [lsearch -exact $menuList $menuEndPath] 1246 if { $end == -1 } { 1247 error "bad menu path \"$menuEndPath\": \ 1248 should be one of $menuList" 1249 } 1250 1251 # now create the list from this range of menus 1252 set delList [lrange $menuList $start $end] 1253 1254 # walk thru them deleting each menu. 1255 # this list has no .menu on the end. 1256 foreach m $delList { 1257 _deleteAMenu $m.menu 1258 } 1259 } 1260} 1261 1262# ------------------------------------------------------------- 1263# 1264# PRIVATE METHOD: _deleteAMenu 1265# 1266# _deleteMenu menuPath 1267# 1268# deletes a single Menu (menubutton and menu pane with entries) 1269# 1270# ------------------------------------------------------------- 1271itcl::body iwidgets::Menubar::_deleteAMenu { path } { 1272 1273 # We will normalize the path to not include the '.menu' if 1274 # it is on the path already. 1275 1276 regsub {[.]menu$} $path "" menuButtonPath 1277 regsub {.*[.]} $menuButtonPath "" buttonName 1278 1279 # Loop through and destroy any cascades, etc on menu. 1280 set entryList [_getEntryList $menuButtonPath] 1281 foreach entry $entryList { 1282 _deleteEntry $entry 1283 } 1284 1285 # Delete the menubutton and menu components... 1286 destroy $itk_component($buttonName-menu) 1287 destroy $itk_component($buttonName) 1288 1289 # This is because of some itcl bug that doesn't delete 1290 # the component on the destroy in some cases... 1291 catch {itk_component delete $buttonName-menu} 1292 catch {itk_component delete $buttonName} 1293 1294 # unset our paths 1295 _unsetPaths $menuButtonPath 1296 1297} 1298 1299# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1300# ENTRY ADD, INSERT, DELETE 1301# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1302 1303# ------------------------------------------------------------- 1304# 1305# PRIVATE METHOD: _addEntry 1306# 1307# Adds an entry to menu. 1308# 1309# ------------------------------------------------------------- 1310itcl::body iwidgets::Menubar::_addEntry { type path args } { 1311 1312 # Error Checking 1313 # '''''''''''''' 1314 # the path should not end with '.menu' 1315 # Not needed -- already checked by add{} 1316 # if { [regexp {[.]menu$} $path] } { 1317 # error "bad entry path: \"$path\". \ 1318 # The name \"menu\" is reserved for menu panes" 1319 # } 1320 1321 # get the tkMenuPath 1322 set tkMenuPath [_entryPathToTkMenuPath $path] 1323 if { $tkMenuPath == "" } { 1324 error "bad entry path: \"$path\". The menu path prefix is not valid" 1325 } 1326 1327 # get the -helpstr option if present 1328 array set temp $args 1329 if { [::info exists temp(-helpstr)] } { 1330 set helpStr $temp(-helpstr) 1331 unset temp(-helpstr) 1332 } else { 1333 set helpStr {} 1334 } 1335 set args [array get temp] 1336 1337 # Handle CASCADE 1338 # '''''''''''''' 1339 # if this is a cascade go ahead and add in the menu... 1340 if { $type == "cascade" } { 1341 eval [list _addCascade $tkMenuPath $path] $args 1342 # Handle Non-CASCADE 1343 # '''''''''''''''''' 1344 } else { 1345 # add the entry if one doesn't already exist with the same 1346 # command name 1347 if [::info exists _pathMap($path)] { 1348 set cmdname [lindex [split $path .] end] 1349 error "Cannot add $type \"$cmdname\". A menu item already\ 1350 exists with this name." 1351 } 1352 eval [list $tkMenuPath add $type] $args 1353 set _pathMap($path) [_getPdIndex $tkMenuPath end] 1354 } 1355 1356 # Remember the help string 1357 set _helpString($path) $helpStr 1358 1359 return $_pathMap($path) 1360} 1361 1362# ------------------------------------------------------------- 1363# 1364# PRIVATE METHOD: _addCascade 1365# 1366# Creates a cascade button. Handles the -menu option 1367# 1368# ------------------------------------------------------------- 1369itcl::body iwidgets::Menubar::_addCascade { tkMenuPath path args } { 1370 1371 # get the cascade name from our path 1372 regsub {.*[.]} $path "" cascadeName 1373 1374 #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 1375 # Capture the -menu option if present 1376 # ''''''''''''''''''''''''''''''''''' 1377 array set temp $args 1378 if { [::info exists temp(-menu)] } { 1379 set menuEvalStr $temp(-menu) 1380 } else { 1381 set menuEvalStr {} 1382 } 1383 1384 # attach the menu pane 1385 set temp(-menu) $tkMenuPath.$cascadeName 1386 set args [array get temp] 1387 1388 # Create the cascade entry 1389 eval $tkMenuPath add cascade $args 1390 1391 # Keep the -menu string in case of menuconfigure or menucget 1392 if { $menuEvalStr != "" } { 1393 set _menuOption($path) $menuEvalStr 1394 } 1395 1396 # update our pathmap 1397 set _pathMap($path) [_getPdIndex $tkMenuPath end] 1398 1399 _makeMenu \ 1400 $cascadeName-menu \ 1401 $tkMenuPath.$cascadeName \ 1402 $path \ 1403 $menuEvalStr 1404 1405 #return $itk_component($cascadeName) 1406 1407} 1408 1409# ------------------------------------------------------------- 1410# 1411# PRIVATE METHOD: _insertEntry 1412# 1413# inserts an entry on a menu before entry given by beforeEntryPath. 1414# The added entry is of type TYPE and its name is NAME. ARGS are 1415# passed for customization of the entry. 1416# 1417# ------------------------------------------------------------- 1418itcl::body iwidgets::Menubar::_insertEntry { beforeEntryPath type name args } { 1419 1420 # convert entryPath to an index value 1421 set bfIndex $_pathMap($beforeEntryPath) 1422 1423 # first verify that beforeEntryPath is actually a path to 1424 # an entry and not to menu, menubutton, etc. 1425 if { ! [regexp {^[0-9]+$} $bfIndex] } { 1426 error "bad entry path: $beforeEntryPath is not an entry" 1427 } 1428 1429 # get the menu path from the entry path name 1430 regsub {[.][^.]*$} $beforeEntryPath "" menuPathPrefix 1431 set tkMenuPath $_pathMap($menuPathPrefix.menu) 1432 1433 # If this entry already exists in the path map, throw an error. 1434 if [::info exists _pathMap($menuPathPrefix.$name)] { 1435 error "Cannot insert $type \"$name\". A menu item already\ 1436 exists with this name." 1437 } 1438 1439 # INDEX is zero based at this point. 1440 1441 # ENTRIES is a zero based list... 1442 set entries [_getEntryList $menuPathPrefix] 1443 1444 # 1445 # Adjust the entries after the inserted item, to have 1446 # the correct index numbers. Note, we stay zero based 1447 # even though tk flips back and forth depending on tearoffs. 1448 # 1449 for {set i $bfIndex} {$i < [llength $entries]} {incr i} { 1450 # path==entry path in numerical order 1451 set path [lindex $entries $i] 1452 1453 # add one to each entry after the inserted one. 1454 set _pathMap($path) [expr {$i + 1}] 1455 } 1456 1457 # get the -helpstr option if present 1458 array set temp $args 1459 if { [::info exists temp(-helpstr)] } { 1460 set helpStr $temp(-helpstr) 1461 unset temp(-helpstr) 1462 } else { 1463 set helpStr {} 1464 } 1465 set args [array get temp] 1466 1467 set path $menuPathPrefix.$name 1468 1469 # Handle CASCADE 1470 # '''''''''''''' 1471 # if this is a cascade go ahead and add in the menu... 1472 if { [string match cascade $type] } { 1473 1474 if { [ catch {eval "_insertCascade \ 1475 $bfIndex $tkMenuPath $path $args"} errMsg ]} { 1476 for {set i $bfIndex} {$i < [llength $entries]} {incr i} { 1477 # path==entry path in numerical order 1478 set path [lindex $entries $i] 1479 1480 # sub the one we added earlier. 1481 set _pathMap($path) [expr {$_pathMap($path) - 1}] 1482 # @@ delete $hs 1483 } 1484 error $errMsg 1485 } 1486 1487 # Handle Entry 1488 # '''''''''''''' 1489 } else { 1490 1491 # give us a zero or 1-based index based on tear-off menu status 1492 # invoke the menu's insert command 1493 if { [catch {eval "$tkMenuPath insert \ 1494 [_getTkIndex $tkMenuPath $bfIndex] $type $args"} errMsg]} { 1495 for {set i $bfIndex} {$i < [llength $entries]} {incr i} { 1496 # path==entry path in numerical order 1497 set path [lindex $entries $i] 1498 1499 # sub the one we added earlier. 1500 set _pathMap($path) [expr {$_pathMap($path) - 1}] 1501 # @@ delete $hs 1502 } 1503 error $errMsg 1504 } 1505 1506 1507 # add the helpstr option to our options list (attach to entry) 1508 set _helpString($path) $helpStr 1509 1510 # Insert the new entry path into pathmap giving it an index value 1511 set _pathMap($menuPathPrefix.$name) $bfIndex 1512 1513 } 1514 1515 return [_getTkIndex $tkMenuPath $bfIndex] 1516} 1517 1518# ------------------------------------------------------------- 1519# 1520# PRIVATE METHOD: _insertCascade 1521# 1522# Creates a cascade button. Handles the -menu option 1523# 1524# ------------------------------------------------------------- 1525itcl::body iwidgets::Menubar::_insertCascade { bfIndex tkMenuPath path args } { 1526 1527 # get the cascade name from our path 1528 regsub {.*[.]} $path "" cascadeName 1529 1530 #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, 1531 # Capture the -menu option if present 1532 # ''''''''''''''''''''''''''''''''''' 1533 array set temp $args 1534 if { [::info exists temp(-menu)] } { 1535 # Keep the -menu string in case of menuconfigure or menucget 1536 set _menuOption($path) $temp(-menu) 1537 set menuEvalStr $temp(-menu) 1538 } else { 1539 set menuEvalStr {} 1540 } 1541 1542 # attach the menu pane 1543 set temp(-menu) $tkMenuPath.$cascadeName 1544 set args [array get temp] 1545 1546 # give us a zero or 1-based index based on tear-off menu status 1547 # invoke the menu's insert command 1548 eval "$tkMenuPath insert \ 1549 [_getTkIndex $tkMenuPath $bfIndex] cascade $args" 1550 1551 # Insert the new entry path into pathmap giving it an index value 1552 set _pathMap($path) $bfIndex 1553 _makeMenu \ 1554 $cascadeName-menu \ 1555 $tkMenuPath.$cascadeName \ 1556 $path \ 1557 $menuEvalStr 1558 1559 #return $itk_component($cascadeName) 1560} 1561 1562# ------------------------------------------------------------- 1563# 1564# PRIVATE METHOD: _deleteEntry 1565# 1566# _deleteEntry entryPath ?entryPath2? 1567# 1568# either 1569# deletes the entry entryPath 1570# or 1571# deletes the entries from entryPath to entryPath2 1572# 1573# ------------------------------------------------------------- 1574itcl::body iwidgets::Menubar::_deleteEntry { entryPath {entryPath2 {}} } { 1575 1576 if { $entryPath2 == "" } { 1577 # get a corrected path (subst for number, last, end) 1578 set path [_parsePath $entryPath] 1579 1580 set entryIndex $_pathMap($path) 1581 if { $entryIndex == -1 } { 1582 error "bad value for pathName: \ 1583 $entryPath in call to delet" 1584 } 1585 1586 # get the type, if cascade, we will want to delete menu 1587 set type [type $path] 1588 1589 # ... munge up the menu name ... 1590 1591 # the tkMenuPath is looked up with the .menu added to lookup 1592 # strip off the entry component 1593 regsub {[.][^.]*$} $path "" menuPath 1594 set tkMenuPath $_pathMap($menuPath.menu) 1595 1596 # get the ordered entry list 1597 set entries [_getEntryList $menuPath] 1598 1599 # ... Fix up path entry indices ... 1600 1601 # delete the path from the map 1602 unset _pathMap([lindex $entries $entryIndex]) 1603 1604 # Subtract off 1 for each entry below the deleted one. 1605 for {set i [expr {$entryIndex + 1}]} \ 1606 {$i < [llength $entries]} \ 1607 {incr i} { 1608 set epath [lindex $entries $i] 1609 incr _pathMap($epath) -1 1610 } 1611 1612 # ... Delete the menu entry widget ... 1613 1614 # delete the menu entry, ajusting index for TK 1615 $tkMenuPath delete [_getTkIndex $tkMenuPath $entryIndex] 1616 1617 if { $type == "cascade" } { 1618 regsub {.*[.]} $path "" cascadeName 1619 destroy $itk_component($cascadeName-menu) 1620 1621 # This is because of some itcl bug that doesn't delete 1622 # the component on the destroy in some cases... 1623 catch {itk_component delete $cascadeName-menu} 1624 1625 _unsetPaths $path 1626 } 1627 1628 } else { 1629 # get a corrected path (subst for number, last, end) 1630 set path1 [_parsePath $entryPath] 1631 set path2 [_parsePath $entryPath2] 1632 1633 set fromEntryIndex $_pathMap($path1) 1634 if { $fromEntryIndex == -1 } { 1635 error "bad value for entryPath1: \ 1636 $entryPath in call to delet" 1637 } 1638 set toEntryIndex $_pathMap($path2) 1639 if { $toEntryIndex == -1 } { 1640 error "bad value for entryPath2: \ 1641 $entryPath2 in call to delet" 1642 } 1643 # ... munge up the menu name ... 1644 1645 # the tkMenuPath is looked up with the .menu added to lookup 1646 # strip off the entry component 1647 regsub {[.][^.]*$} $path1 "" menuPath 1648 set tkMenuPath $_pathMap($menuPath.menu) 1649 1650 # get the ordered entry list 1651 set entries [_getEntryList $menuPath] 1652 1653 # ... Fix up path entry indices ... 1654 1655 # delete the range from the pathMap list 1656 for {set i $fromEntryIndex} {$i <= $toEntryIndex} {incr i} { 1657 unset _pathMap([lindex $entries $i]) 1658 } 1659 1660 # Subtract off 1 for each entry below the deleted range. 1661 # Loop from one below the bottom delete entry to end list 1662 for {set i [expr {$toEntryIndex + 1}]} \ 1663 {$i < [llength $entries]} \ 1664 {incr i} { 1665 # take this path and sets its index back by size of 1666 # deleted range. 1667 set path [lindex $entries $i] 1668 set _pathMap($path) \ 1669 [expr {$_pathMap($path) - \ 1670 (($toEntryIndex - $fromEntryIndex) + 1)}] 1671 } 1672 1673 # ... Delete the menu entry widget ... 1674 1675 # delete the menu entry, ajusting index for TK 1676 $tkMenuPath delete \ 1677 [_getTkIndex $tkMenuPath $fromEntryIndex] \ 1678 [_getTkIndex $tkMenuPath $toEntryIndex] 1679 1680 } 1681} 1682 1683# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1684# CONFIGURATION SUPPORT 1685# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1686# ------------------------------------------------------------- 1687# 1688# PRIVATE METHOD: _configureMenu 1689# 1690# This configures a menu. A menu is a true tk widget, thus we 1691# pass the tkPath variable. This path may point to either a 1692# menu button (does not end with the name 'menu', or a menu 1693# which ends with the name 'menu' 1694# 1695# path : our Menubar path name to this menu button or menu pane. 1696# if we end with the name '.menu' then it is a menu pane. 1697# tkPath : the path to the corresponding Tk menubutton or menu. 1698# args : the args for configuration 1699# 1700# ------------------------------------------------------------- 1701itcl::body iwidgets::Menubar::_configureMenu { path tkPath {option {}} args } { 1702 1703 set class [winfo class $tkPath] 1704 1705 if { $option == "" } { 1706 # No arguments: return all options 1707 set configList [$tkPath configure] 1708 1709 if { [info exists _menuOption($path)] } { 1710 lappend configList [list -menu menu Menu {} $_menuOption($path)] 1711 } else { 1712 lappend configList [list -menu menu Menu {} {}] 1713 } 1714 if { [info exists _helpString($path)] } { 1715 lappend configList [list -helpstr helpStr HelpStr {} \ 1716 $_helpString($path)] 1717 } else { 1718 lappend configList [list -helpstr helpStr HelpStr {} {}] 1719 } 1720 return $configList 1721 1722 } elseif {$args == "" } { 1723 if { $option == "-menu" } { 1724 if { [info exists _menuOption($path)] } { 1725 return [list -menu menu Menu {} $_menuOption($path)] 1726 } else { 1727 return [list -menu menu Menu {} {}] 1728 } 1729 } elseif { $option == "-helpstr" } { 1730 if { [info exists _helpString($path)] } { 1731 return [list -helpstr helpStr HelpStr {} $_helpString($path)] 1732 } else { 1733 return [list -helpstr helpStr HelpStr {} {}] 1734 } 1735 } else { 1736 # ... OTHERWISE, let Tk get it. 1737 return [$tkPath configure $option] 1738 } 1739 } else { 1740 set args [concat $option $args] 1741 1742 # If this is a menubutton, and has -menu option, process it 1743 if { $class == "Menubutton" && [regexp -- {-menu} $args] } { 1744 eval _configureMenuOption menubutton $path $args 1745 } else { 1746 eval $tkPath configure $args 1747 } 1748 return "" 1749 } 1750} 1751 1752# ------------------------------------------------------------- 1753# 1754# PRIVATE METHOD: _configureMenuOption 1755# 1756# Allows for configuration of the -menu option on 1757# menubuttons and cascades 1758# 1759# find out if we are the last menu, or are before one. 1760# delete the old menu. 1761# if we are the last, then add us back at the end 1762# if we are before another menu, get the beforePath 1763# 1764# ------------------------------------------------------------- 1765itcl::body iwidgets::Menubar::_configureMenuOption { type path args } { 1766 1767 regsub {[.][^.]*$} $path "" pathPrefix 1768 1769 if { $type == "menubutton" } { 1770 set menuList [_getMenuList] 1771 set pos [lsearch $menuList $path] 1772 if { $pos == ([llength $menuList] - 1) } { 1773 set insert false 1774 } else { 1775 set insert true 1776 } 1777 } elseif { $type == "cascade" } { 1778 set lastEntryPath [_parsePath $pathPrefix.last] 1779 if { $lastEntryPath == $path } { 1780 set insert false 1781 } else { 1782 set insert true 1783 } 1784 set pos [index $path] 1785 1786 } 1787 1788 1789 eval "delete $pathPrefix.$pos" 1790 if { $insert } { 1791 # get name from path... 1792 regsub {.*[.]} $path "" name 1793 1794 eval insert $pathPrefix.$pos $type \ 1795 $name $args 1796 } else { 1797 eval add $type $path $args 1798 } 1799} 1800 1801# ------------------------------------------------------------- 1802# 1803# PRIVATE METHOD: _configureMenuEntry 1804# 1805# This configures a menu entry. A menu entry is either a command, 1806# radiobutton, separator, checkbutton, or a cascade. These have 1807# a corresponding Tk index value for the corresponding tk menu 1808# path. 1809# 1810# path : our Menubar path name to this menu entry. 1811# index : the t 1812# args : the args for configuration 1813# 1814# ------------------------------------------------------------- 1815itcl::body iwidgets::Menubar::_configureMenuEntry { path index {option {}} args } { 1816 1817 set type [type $path] 1818 1819 # set len [llength $args] 1820 1821 # get the menu path from the entry path name 1822 set tkMenuPath [_entryPathToTkMenuPath $path] 1823 1824 if { $option == "" } { 1825 set configList [$tkMenuPath entryconfigure \ 1826 [_getTkIndex $tkMenuPath $index]] 1827 1828 if { $type == "cascade" } { 1829 if { [info exists _menuOption($path)] } { 1830 lappend configList [list -menu menu Menu {} \ 1831 $_menuOption($path)] 1832 } else { 1833 lappend configList [list -menu menu Menu {} {}] 1834 } 1835 } 1836 if { [info exists _helpString($path)] } { 1837 lappend configList [list -helpstr helpStr HelpStr {} \ 1838 $_helpString($path)] 1839 } else { 1840 lappend configList [list -helpstr helpStr HelpStr {} {}] 1841 } 1842 return $configList 1843 1844 } elseif { $args == "" } { 1845 if { $option == "-menu" } { 1846 if { [info exists _menuOption($path)] } { 1847 return [list -menu menu Menu {} $_menuOption($path)] 1848 } else { 1849 return [list -menu menu Menu {} {}] 1850 } 1851 } elseif { $option == "-helpstr" } { 1852 if { [info exists _helpString($path)] } { 1853 return [list -helpstr helpStr HelpStr {} \ 1854 $_helpString($path)] 1855 } else { 1856 return [list -helpstr helpStr HelpStr {} {}] 1857 } 1858 } else { 1859 # ... OTHERWISE, let Tk get it. 1860 return [$tkMenuPath entryconfigure \ 1861 [_getTkIndex $tkMenuPath $index] $option] 1862 } 1863 } else { 1864 array set temp [concat $option $args] 1865 1866 # ... Store -helpstr val,strip out -helpstr val from args 1867 if { [::info exists temp(-helpstr)] } { 1868 set _helpString($path) $temp(-helpstr) 1869 unset temp(-helpstr) 1870 } 1871 1872 set args [array get temp] 1873 if { $type == "cascade" && [::info exists temp(-menu)] } { 1874 eval "_configureMenuOption cascade $path $args" 1875 } else { 1876 # invoke the menu's entryconfigure command 1877 # being careful to ajust the INDEX to be 0 or 1 based 1878 # depending on the tearoff status 1879 # if the stripping process brought us down to no options 1880 # to set, then forget the configure of widget. 1881 if { [llength $args] != 0 } { 1882 eval $tkMenuPath entryconfigure \ 1883 [_getTkIndex $tkMenuPath $index] $args 1884 } 1885 } 1886 return "" 1887 } 1888} 1889 1890# ------------------------------------------------------------- 1891# 1892# PRIVATE METHOD: _unsetPaths 1893# 1894# comment 1895# 1896# ------------------------------------------------------------- 1897itcl::body iwidgets::Menubar::_unsetPaths { parent } { 1898 1899 # first get the complete list of all menu paths 1900 set pathList [array names _pathMap] 1901 1902 # for each path that matches parent prefix, unset it. 1903 foreach path $pathList { 1904 if { [regexp [subst -nocommands {^$parent}] $path] } { 1905 unset _pathMap($path) 1906 } 1907 } 1908} 1909 1910# ------------------------------------------------------------- 1911# 1912# PRIVATE METHOD: _entryPathToTkMenuPath 1913# 1914# Takes an entry path like .mbar.file.new and changes it to 1915# .mbar.file.menu and performs a lookup in the pathMap to 1916# get the corresponding menu widget name for tk 1917# 1918# ------------------------------------------------------------- 1919itcl::body iwidgets::Menubar::_entryPathToTkMenuPath {entryPath} { 1920 1921 # get the menu path from the entry path name 1922 # by stripping off the entry component of the path 1923 regsub {[.][^.]*$} $entryPath "" menuPath 1924 1925 # the tkMenuPath is looked up with the .menu added to lookup 1926 if { [catch {set tkMenuPath $_pathMap($menuPath.menu)}] } { 1927 return "" 1928 } else { 1929 return $_pathMap($menuPath.menu) 1930 } 1931} 1932 1933 1934# ------------------------------------------------------------- 1935# 1936# These two methods address the issue of menu entry indices being 1937# zero-based when the menu is not a tearoff menu and 1-based when 1938# it is a tearoff menu. Our strategy is to hide this difference. 1939# 1940# _getTkIndex returns the index as tk likes it: 0 based for non-tearoff 1941# and 1 based for tearoff menus. 1942# 1943# _getPdIndex (get pulldown index) always returns it as 0 based. 1944# 1945# ------------------------------------------------------------- 1946 1947# ------------------------------------------------------------- 1948# 1949# PRIVATE METHOD: _getTkIndex 1950# 1951# give us a zero or 1-based answer depending on the tearoff 1952# status of the menu. If the menu denoted by tkMenuPath is a 1953# tearoff menu it returns a 1-based result, otherwise a 1954# zero-based result. 1955# 1956# ------------------------------------------------------------- 1957itcl::body iwidgets::Menubar::_getTkIndex { tkMenuPath tkIndex} { 1958 1959 # if there is a tear off make it 1-based index 1960 if { [$tkMenuPath cget -tearoff] } { 1961 incr tkIndex 1962 } 1963 1964 return $tkIndex 1965} 1966 1967# ------------------------------------------------------------- 1968# 1969# PRIVATE METHOD: _getPdIndex 1970# 1971# Take a tk index and give me a zero based numerical index 1972# 1973# Ask the menu widget for the index of the entry denoted by 1974# 'tkIndex'. Then if the menu is a tearoff adjust the value 1975# to be zero based. 1976# 1977# This method returns the index as if tearoffs did not exist. 1978# Always returns a zero-based index. 1979# 1980# ------------------------------------------------------------- 1981itcl::body iwidgets::Menubar::_getPdIndex { tkMenuPath tkIndex } { 1982 1983 # get the index from the tk menu 1984 # this 0 based for non-tearoff and 1-based for tearoffs 1985 set pdIndex [$tkMenuPath index $tkIndex] 1986 1987 # if there is a tear off make it 0-based index 1988 if { [$tkMenuPath cget -tearoff] } { 1989 incr pdIndex -1 1990 } 1991 1992 return $pdIndex 1993} 1994 1995# ------------------------------------------------------------- 1996# 1997# PRIVATE METHOD: _getMenuList 1998# 1999# Returns the list of menus in the order they are on the interface 2000# returned list is a list of our menu paths 2001# 2002# ------------------------------------------------------------- 2003itcl::body iwidgets::Menubar::_getMenuList { } { 2004 # get the menus that are packed 2005 set tkPathList [pack slaves $itk_component(menubar)] 2006 2007 regsub -- {[.]} $itk_component(hull) "" mbName 2008 regsub -all -- "\[.\]$mbName\[.\]menubar\[.\]" $tkPathList "." menuPathList 2009 2010 return $menuPathList 2011} 2012 2013# ------------------------------------------------------------- 2014# 2015# PRIVATE METHOD: _getEntryList 2016# 2017# 2018# This method looks at a menupath and gets all the entries and 2019# returns a list of all the entry path names in numerical order 2020# based on their index values. 2021# 2022# MENU is the path to a menu, like .mbar.file.menu or .mbar.file 2023# we will calculate a menuPath from this: .mbar.file 2024# then we will build a list of entries in this menu excluding the 2025# path .mbar.file.menu 2026# 2027# ------------------------------------------------------------- 2028itcl::body iwidgets::Menubar::_getEntryList { menu } { 2029 2030 # if it ends with menu, clip it off 2031 regsub {[.]menu$} $menu "" menuPath 2032 2033 # first get the complete list of all menu paths 2034 set pathList [array names _pathMap] 2035 2036 set numEntries 0 2037 # iterate over the pathList and put on menuPathList those 2038 # that match the menuPattern 2039 foreach path $pathList { 2040 # if this path is on the menuPath's branch 2041 if { [regexp [subst -nocommands {$menuPath[.][^.]*$}] $path] } { 2042 # if not a menu itself 2043 if { ! [regexp {[.]menu$} $path] } { 2044 set orderedList($_pathMap($path)) $path 2045 incr numEntries 2046 } 2047 } 2048 } 2049 set entryList {} 2050 2051 for {set i 0} {$i < $numEntries} {incr i} { 2052 lappend entryList $orderedList($i) 2053 } 2054 2055 return $entryList 2056 2057} 2058 2059# ------------------------------------------------------------- 2060# 2061# PRIVATE METHOD: _parsePath 2062# 2063# given path, PATH, _parsePath splits the path name into its 2064# component segments. It then puts the name back together one 2065# segment at a time and calls _getSymbolicPath to replace the 2066# keywords 'last' and 'end' as well as numeric digits. 2067# 2068# ------------------------------------------------------------- 2069itcl::body iwidgets::Menubar::_parsePath { path } { 2070 set segments [split [string trimleft $path .] .] 2071 2072 set concatPath "" 2073 foreach seg $segments { 2074 2075 set concatPath [_getSymbolicPath $concatPath $seg] 2076 2077 if { [catch {set _pathMap($concatPath)} ] } { 2078 error "bad path: \"$path\" does not exist. \"$seg\" not valid" 2079 } 2080 } 2081 return $concatPath 2082} 2083 2084# ------------------------------------------------------------- 2085# 2086# PRIVATE METHOD: _getSymbolicPath 2087# 2088# Given a PATH, _getSymbolicPath looks for the last segment of 2089# PATH to contain: a number, the keywords last or end. If one 2090# of these it figures out how to get us the actual pathname 2091# to the searched widget 2092# 2093# Implementor's notes: 2094# Surely there is a shorter way to do this. The only diff 2095# for non-numeric is getting the llength of the correct list 2096# It is hard to know this upfront so it seems harder to generalize. 2097# 2098# ------------------------------------------------------------- 2099itcl::body iwidgets::Menubar::_getSymbolicPath { parent segment } { 2100 2101 # if the segment is a number, then look it up positionally 2102 # MATCH numeric index 2103 if { [regexp {^[0-9]+$} $segment] } { 2104 2105 # if we have no parent, then we area menubutton 2106 if { $parent == {} } { 2107 set returnPath [lindex [_getMenuList] $segment] 2108 } else { 2109 set returnPath [lindex [_getEntryList $parent.menu] $segment] 2110 } 2111 2112 # MATCH 'end' or 'last' keywords. 2113 } elseif { $segment == "end" || $segment == "last" } { 2114 2115 # if we have no parent, then we are a menubutton 2116 if { $parent == {} } { 2117 set returnPath [lindex [_getMenuList] end] 2118 } else { 2119 set returnPath [lindex [_getEntryList $parent.menu] end] 2120 } 2121 } else { 2122 set returnPath $parent.$segment 2123 } 2124 2125 return $returnPath 2126} 2127 2128# ------------------------------------------------------------- 2129# 2130# PRIVATE METHOD: _helpHandler 2131# 2132# Bound to the <Motion> event on a menu pane. This puts the 2133# help string associated with the menu entry into the 2134# status widget help area. If no help exists for the current 2135# entry, the status widget is cleared. 2136# 2137# ------------------------------------------------------------- 2138itcl::body iwidgets::Menubar::_helpHandler { menuPath } { 2139 2140 if { $itk_option(-helpvariable) == {} } { 2141 return 2142 } 2143 2144 set tkMenuWidget $_pathMap($menuPath) 2145 2146 set entryIndex [$tkMenuWidget index active] 2147 2148 # already on this item? 2149 if { $entryIndex == $_entryIndex } { 2150 return 2151 } 2152 2153 set _entryIndex $entryIndex 2154 2155 if {"none" != $entryIndex} { 2156 set entries [_getEntryList $menuPath] 2157 2158 set menuEntryHit \ 2159 [lindex $entries [_getPdIndex $tkMenuWidget $entryIndex]] 2160 2161 # blank out the old one 2162 set $itk_option(-helpvariable) {} 2163 2164 # if there is a help string for this entry 2165 if { [::info exists _helpString($menuEntryHit)] } { 2166 set $itk_option(-helpvariable) $_helpString($menuEntryHit) 2167 } 2168 } else { 2169 set $itk_option(-helpvariable) {} 2170 set _entryIndex -1 2171 } 2172} 2173 2174# ------------------------------------------------------------- 2175# 2176# PRIVATE METHOD: _getCallerLevel 2177# 2178# Starts at stack frame #0 and works down till we either hit 2179# a ::Menubar stack frame or an ::itk::Archetype stack frame 2180# (the latter happens when a configure is called via the 'component' 2181# method 2182# 2183# Returns the level of the actual caller of the menubar command 2184# in the form of #num where num is the level number caller stack frame. 2185# 2186# ------------------------------------------------------------- 2187itcl::body iwidgets::Menubar::_getCallerLevel { } { 2188 2189 set levelName {} 2190 set levelsAreValid true 2191 set level 0 2192 set callerLevel #$level 2193 2194 while { $levelsAreValid } { 2195 # Hit the end of the stack frame 2196 if [catch {uplevel #$level {namespace current}}] { 2197 set levelsAreValid false 2198 set callerLevel #[expr {$level - 1}] 2199 # still going 2200 } else { 2201 set newLevelName [uplevel #$level {namespace current}] 2202 # See if we have run into the first ::Menubar level 2203 if { $newLevelName == "::itk::Archetype" || \ 2204 $newLevelName == "::iwidgets::Menubar" } { 2205 # If so, we are done-- set the callerLevel 2206 set levelsAreValid false 2207 set callerLevel #[expr {$level - 1}] 2208 } else { 2209 set levelName $newLevelName 2210 } 2211 } 2212 incr level 2213 } 2214 return $callerLevel 2215} 2216 2217 2218# 2219# The default tkMenuFind proc in menu.tcl only looks for menubuttons 2220# in frames. Since our menubuttons are within the Menubar class, the 2221# default proc won't find them during menu traversal. This proc 2222# redefines the default proc to remedy the problem. 2223#----------------------------------------------------------- 2224# BUG FIX: csmith (Chad Smith: csmith@adc.com), 3/30/99 2225#----------------------------------------------------------- 2226# The line, "set qchild ..." below had a typo. It should be 2227# "info command $child" instead of "winfo command $child". 2228#----------------------------------------------------------- 2229proc tkMenuFind {w char} { 2230 global tkPriv 2231 set char [string tolower $char] 2232 2233 # Added by csmith, 5/10/01, to fix a bug reported on the itcl mailing list. 2234 if {$w == "."} { 2235 foreach child [winfo child $w] { 2236 set match [tkMenuFind $child $char] 2237 if {$match != ""} { 2238 return $match 2239 } 2240 } 2241 return {} 2242 } 2243 2244 foreach child [winfo child $w] { 2245 switch [winfo class $child] { 2246 Menubutton { 2247 set qchild [info command $child] 2248 set char2 [string index [$qchild cget -text] \ 2249 [$qchild cget -underline]] 2250 if {([string compare $char [string tolower $char2]] == 0) 2251 || ($char == "")} { 2252 if {[$qchild cget -state] != "disabled"} { 2253 return $child 2254 } 2255 } 2256 } 2257 Frame - 2258 Menubar { 2259 set match [tkMenuFind $child $char] 2260 if {$match != ""} { 2261 return $match 2262 } 2263 } 2264 } 2265 } 2266 return {} 2267} 2268