home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / menubar.itk < prev    next >
Text File  |  2003-09-01  |  72KB  |  2,268 lines
  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. #
  69. itk::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.  
  76. itcl::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. #
  169. option add *Menubar*Menu*tearOff         false        widgetDefault
  170. option add *Menubar*Menubutton*relief    flat         widgetDefault
  171. option add *Menubar*Menu*relief          raised       widgetDefault
  172.  
  173. #
  174. # Provide a lowercase access method for the menubar class
  175. #
  176. proc ::iwidgets::menubar { args } {
  177.     uplevel ::iwidgets::Menubar $args
  178. }
  179.  
  180. # ------------------------------------------------------------------
  181. #                           CONSTRUCTOR
  182. # ------------------------------------------------------------------
  183. itcl::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. # ------------------------------------------------------------------
  226. itcl::configbody iwidgets::Menubar::foreground {
  227. }
  228.  
  229. # ------------------------------------------------------------------
  230. # OPTION -activebackground
  231. #
  232. # menu
  233. # menubutton
  234. # ------------------------------------------------------------------
  235. itcl::configbody iwidgets::Menubar::activebackground {
  236. }
  237.  
  238. # ------------------------------------------------------------------
  239. # OPTION -activeborderwidth
  240. #
  241. # menu
  242. # ------------------------------------------------------------------
  243. itcl::configbody iwidgets::Menubar::activeborderwidth {
  244. }
  245.  
  246. # ------------------------------------------------------------------
  247. # OPTION -activeforeground
  248. #
  249. # menu
  250. # menubutton
  251. # ------------------------------------------------------------------
  252. itcl::configbody iwidgets::Menubar::activeforeground {
  253. }
  254.  
  255. # ------------------------------------------------------------------
  256. # OPTION -anchor
  257. #
  258. # menubutton
  259. # ------------------------------------------------------------------
  260. itcl::configbody iwidgets::Menubar::anchor {
  261. }
  262.  
  263. # ------------------------------------------------------------------
  264. # OPTION -borderwidth
  265. #
  266. # menu
  267. # menubutton
  268. # ------------------------------------------------------------------
  269. itcl::configbody iwidgets::Menubar::borderwidth {
  270. }
  271.  
  272. # ------------------------------------------------------------------
  273. # OPTION -disabledforeground
  274. #
  275. # menu
  276. # menubutton
  277. # ------------------------------------------------------------------
  278. itcl::configbody iwidgets::Menubar::disabledforeground {
  279. }
  280.  
  281. # ------------------------------------------------------------------
  282. # OPTION -font
  283. #
  284. # menu
  285. # menubutton
  286. # ------------------------------------------------------------------
  287. itcl::configbody iwidgets::Menubar::font {
  288. }
  289.  
  290. # ------------------------------------------------------------------
  291. # OPTION -highlightbackground
  292. #
  293. # menubutton
  294. # ------------------------------------------------------------------
  295. itcl::configbody iwidgets::Menubar::highlightbackground {
  296. }
  297.  
  298. # ------------------------------------------------------------------
  299. # OPTION -highlightcolor
  300. #
  301. # menubutton
  302. # ------------------------------------------------------------------
  303. itcl::configbody iwidgets::Menubar::highlightcolor {
  304. }
  305.  
  306. # ------------------------------------------------------------------
  307. # OPTION -highlightthickness
  308. #
  309. # menubutton
  310. # ------------------------------------------------------------------
  311. itcl::configbody iwidgets::Menubar::highlightthickness {
  312. }
  313.  
  314. # ------------------------------------------------------------------
  315. # OPTION -justify
  316. #
  317. # menubutton
  318. # ------------------------------------------------------------------
  319. itcl::configbody iwidgets::Menubar::justify {
  320. }
  321.  
  322. # ------------------------------------------------------------------
  323. # OPTION -padx
  324. #
  325. # menubutton
  326. # ------------------------------------------------------------------
  327. itcl::configbody iwidgets::Menubar::padx {
  328. }
  329.  
  330. # ------------------------------------------------------------------
  331. # OPTION -pady
  332. #
  333. # menubutton
  334. # ------------------------------------------------------------------
  335. itcl::configbody iwidgets::Menubar::pady {
  336. }
  337.  
  338. # ------------------------------------------------------------------
  339. # OPTION -wraplength
  340. #
  341. # menubutton
  342. # ------------------------------------------------------------------
  343. itcl::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. # ------------------------------------------------------------------
  355. itcl::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. # ------------------------------------------------------------------
  394. itcl::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. # -------------------------------------------------------------
  451. itcl::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. # -------------------------------------------------------------
  500. itcl::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. # -------------------------------------------------------------
  545. itcl::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. # -------------------------------------------------------------
  594. itcl::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. # -------------------------------------------------------------
  639. itcl::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. # -------------------------------------------------------------
  675. itcl::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. # -------------------------------------------------------------
  699. itcl::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. # -------------------------------------------------------------
  741. itcl::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. # -------------------------------------------------------------
  792. itcl::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. # -------------------------------------------------------------
  842. itcl::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. # -------------------------------------------------------------
  884. itcl::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. # -------------------------------------------------------------
  899. itcl::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. # -------------------------------------------------------------
  917. itcl::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. # -------------------------------------------------------------
  943. itcl::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. # -------------------------------------------------------------
  958. itcl::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. # -------------------------------------------------------------
  973. itcl::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. # -------------------------------------------------------------
  990. itcl::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. # -------------------------------------------------------------
  1017. itcl::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. # -------------------------------------------------------------
  1041. itcl::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. # -------------------------------------------------------------
  1065. itcl::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. # -------------------------------------------------------------
  1132. itcl::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. # -------------------------------------------------------------
  1196. itcl::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. # -------------------------------------------------------------
  1216. itcl::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. # -------------------------------------------------------------
  1271. itcl::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. # -------------------------------------------------------------
  1310. itcl::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. # -------------------------------------------------------------
  1369. itcl::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. # -------------------------------------------------------------
  1418. itcl::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. # -------------------------------------------------------------
  1525. itcl::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. # -------------------------------------------------------------
  1574. itcl::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. # -------------------------------------------------------------
  1701. itcl::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. # -------------------------------------------------------------
  1765. itcl::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. # -------------------------------------------------------------
  1815. itcl::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. # -------------------------------------------------------------
  1897. itcl::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. # -------------------------------------------------------------
  1919. itcl::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. # -------------------------------------------------------------
  1957. itcl::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. # -------------------------------------------------------------
  1981. itcl::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. # -------------------------------------------------------------
  2003. itcl::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. # -------------------------------------------------------------
  2028. itcl::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. # -------------------------------------------------------------
  2069. itcl::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. # -------------------------------------------------------------
  2099. itcl::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. # -------------------------------------------------------------
  2138. itcl::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. # -------------------------------------------------------------
  2187. itcl::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. #-----------------------------------------------------------
  2229. proc 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.