Updated 2007-06-24 13:47:49 by dkf

RBR - Inspired by Menus Even Easier, I decided to modify the code a bit to put it in its own namespace to avoid stepping on some common names, e.g., push. Here is the new code, the example in Menus Even Easier should still work with this, provided you do a namespace import ::mm::* (see namespace [1]) which will import only the mm command itself.

Version 1.7 fixes the use of -parent . for the menubar by just dropping it. The parent is '.' by default anyway. It also fixes the check for toplevel-ness of the -parent widget. Got rid of -cmd and -label options special handling since the underlying widget can handle them more correctly and completely. The -cmd is really just an alias for -command (in the original) and you now must use -command.

Version 1.6 fixes a problem with checkbuttons that have multi-word labels and adds the ability to specify -value so that checkbutton values are independent of their labels. I also made the help menu recognized as a special menu, unix-style. This is arguably the wrong thing to do since it is not behaving in the appropriate platform special mode. I also added a -parent specification for the menu keyword to make the menu a menubar for an arbitrary toplevel widget.

Version 1.4 adds the ability to specify arbitrary options to the underlying widgets, e.g., -underline and -accelerator. An example follows the code for tkMenuMgr.

There are still some things to be added, and some potential gotchas. First, I've done away with special handling of -cmd and -label. You will have to take anything that used -cmd and change it to -command. Both -command and -label are handled by the underlying widgetI'd like to do away with the special treatment of -cmd, -var, and anything else that can be handled via the underlying widget. Second, commands must be specified as strings due to the way the mm command is parsed. I'm sure there are some others I can't think of right now. Send me email (mailto:roland@astrofoto.org) if you have a suggestion. I'm actively using this and still tweaking my copy, so I may have already incorporated the change....
 #
 # Copyright © 2002, Larry Smith
 # Copyright © 2002–2003 Roland B. Roberts <roland@astrofoto.org>
 #
 # RCS Revision
 #   @@(#) $Id: 4710,v 1.27 2005-11-26 07:00:28 jcw Exp $
 #   $Source: /home/kennykb/Tcl/wiki/cvsroot/twhist/4710,v $
 #
 # KNOWN LIMITATIONS
 #   o Can't use -when with the top-most menu buttons.  This is not a
 #     big deal except when trying to imitate some stylistically challenged
 #     Windows applications.
 #
 # WISH LIST
 #   o Make -accelerator recognized and automatically generate the
 #     keystroke bindings required to invoke the command.
 #

 package provide tkMenuMgr [lindex [regexp -inline {,v ([0-9.]+) } {@(#) $Id: 4710,v 1.27 2005-11-26 07:00:28 jcw Exp $}] 1]

 namespace eval mm {
     # Create an entire menu hierachy from a description.  It can
     # control all functions in the hierachy, enabling them and
     # disabling them as your program changes state.  Keeps torn-off
     # menus in sync with home menu.

     namespace export mm

     variable stack ""
     variable funclist ""
     variable menulist ""
     variable indxlist ""
     variable toplist ""
     variable nextwidget 0
     variable torn

 }

 namespace eval ::mm::stack {
 }

 #################################################################
 #                                                               #
 #  __ _             _                           _       _       #
 # / _\ |_ __ _  ___| | _____    /\/\   ___   __| |_   _| | ___  #
 # \ \| __/ _` |/ __| |/ / __|  /    \ / _ \ / _` | | | | |/ _ \ #
 # _\ \ || (_| | (__|   <\__ \ / /\/\ \ (_) | (_| | |_| | |  __/ #
 # \__/\__\__,_|\___|_|\_\___/ \/    \/\___/ \__,_|\__,_|_|\___| #
 #                                                               #
 #################################################################

 proc ::mm::stack::height { stack } {
     upvar $stack s
     return [ llength $s ]
 }

 proc ::mm::stack::push { stack str } {
     upvar $stack s
     lappend s $str
 }

 proc ::mm::stack::pull { stack } {
     upvar $stack s

     if { $s == "" } return ""
     set result [ lindex $s end ]
     set s [ lreplace $s end end ]
     return $result
 }

 proc ::mm::stack::peek { stack } {
     upvar $stack s
     if { $s == "" } return ""
     return [ lindex $s end ]
 }

 # returns the entire stack as a pathname using the
 # given separator.  The last argument can be "prefix",
 # "suffix" or both, and indicates whether the separator
 # will precede the pathname, follow the pathname, or
 # both, resulting in .a.b.c, a.b.c. or .a.b.c.

 proc ::mm::stack::pathname { stack { separator "." } { how prefix } } {
     upvar $stack s
     set result ""
     if { "$how" != "suffix" } {
	 foreach n $s {
	     append result $separator $n
	 }
     } else {
	 foreach n $s {
	     append result $n $separator
	 }
     }
     if { "$how" == "both" } {
	 append result $separator
     }
     return $result
 }

 proc ::mm::stack::pushpath { stack pathname { separator "." } } {
     upvar $stack s
     set s [ split $pathname $separator ]
     if { [ lindex $s 0 ] == "" } { set s [ lreplace $s 0 0 ] }
 }

 #################################################################
 #                                                               #
 #                                             _       _         #
 #   /\/\   ___ _ __  _   _    /\/\   ___   __| |_   _| | ___    #
 #  /    \ / _ \ '_ \| | | |  /    \ / _ \ / _` | | | | |/ _ \   #
 # / /\/\ \  __/ | | | |_| | / /\/\ \ (_) | (_| | |_| | |  __/   #
 # \/    \/\___|_| |_|\__,_| \/    \/\___/ \__,_|\__,_|_|\___|   #
 #                                                               #
 #################################################################

 # returns a string for the next widget name
 proc ::mm::GetName { } {
     variable nextwidget

     set result w$nextwidget
     incr nextwidget
     return $result
 }

 # Scans for -foo "str" pairs and converts them into variable/value
 # pairs in the surrounding scope - i.e.  -foo "str" becomes "foo" with
 # a value of "str" in the calling routine.
 # Returns a list of switches which are NOT "when", "init", or "var".
 proc ::mm::DoSwitches { args } {
     upvar $args arglist

     set rest {}
     set max [ llength $arglist ]
     if { $max == 1 } {
	 # braced set of args
	 eval set arglist $arglist
	 set max [ llength $arglist ]
     }
     # puts "arglist => $arglist"
     for { set i 0 } { $i <= $max } { } {
	 set s [ lindex $arglist $i ]
	 if { [ string index $s 0 ] == "-" } {
	     set var [ string range $s 1 end ]
	     incr i
	     if { $i < $max } {
		 set val [ lindex $arglist $i ]
		 if { [ string index $val 0 ] != "-" } {
		     uplevel 1 set $var \{$val\}
		     switch -exact $var {
			 when -
			 init -
			 var {}
			 default {
			     lappend rest $s $val
			 }
		     }
		     continue
		 }
	     }
	     uplevel 1 set $var 1
	 }
	 incr i
     }
     # puts "rest => $rest"
     return $rest
 }

 proc ::mm::SplitSwitchesAndCommands { args } {

     set switches {}
     set rest {}
     set max [ llength $args ]
     if { $max == 1 } {
	 # braced set of args
	 eval set args $args
	 set max [ llength $args ]
     }
     for { set i 0 } { $i <= $max } { } {
	 set s [ lindex $args $i ]
	 if { [ string index $s 0 ] == "-" } {
	     incr i
	     if { $i < $max } {
		 set val [ lindex $args $i ]
		 if { [ string index $val 0 ] != "-" } {
		     lappend switches $s $val
		 }
	     }
	 } elseif { [ string length $s ] > 0 } {
	     lappend rest $s
	 }
	 incr i
     }
     return [list $switches [lindex $rest 0]]
 }

 # Removes and returns the 1st element of a list
 proc ::mm::First { args } {
     upvar $args arglist

     set rtn [ lindex $arglist 0 ]
     set arglist [ lreplace $arglist 0 0 ]
     return $rtn
 }

 # called when a menu is torn off, saves the name
 # of the torn-off menu so entries on it are con-
 # trolled like regular menu entries.
 proc ::mm::TearOffControl { parent newwidget } {
     variable torn

     if { [ info exists torn($parent) ] == 0 } {
	 set torn($parent) ""
     }
     ::mm::stack::push torn($parent) $newwidget
 }

 # returns list of menus torn off of this main one.
 proc ::mm::GetTearOffs { parent } {
     variable torn

     if { [ info exists torn($parent) ] == 1 } {
	 return $torn($parent)
     } else {
	 return ""
     }
 }

 # removes a torn-off menu that no longer exists.
 proc ::mm::DeleteTearOffs { parent w } {
     variable torn

     set i [ lsearch -exact $torn($parent) $w ]
     set torn($parent) [lreplace torn($parent) $i $i]
 }

 proc ::mm::SetState { active widget index } {
     if { $active } {
	 $widget entryconfigure $index -state normal
     } else {
	 $widget entryconfigure $index -state disabled
     }
 }

 proc ::mm::SaveControl { widget when index } {
     variable menulist
     variable funclist
     variable indxlist

     ::mm::stack::push menulist $widget
     ::mm::stack::push funclist $when
     ::mm::stack::push indxlist $index
 }

 # the menu mgr proper
 proc ::mm::mm { keyword args } {
     variable stack
     variable menulist
     variable funclist
     variable indxlist

     if { "$keyword" == "menubar" } {

	 # FIXME: This is wrong if -parent was specified.  However, it
	 # will always be the case that .w0 is the _relative_ path from
	 # widget specified in -parent.

	 return ".w0"

     } elseif { "$keyword" == "menu" } {
	 # mm menu - defines a new menu

	 set label [ First args ]

	 foreach {switches body} [ ::mm::SplitSwitchesAndCommands $args ] {}

	 if {[set idx [lsearch $switches {-parent}]] >= 0} {
	     if {![string equal [lindex $switches [expr {1+$idx}]] .]} {
		 set parent [lindex $switches [expr {1+$idx}]]
		 if {![string equal [winfo toplevel $parent] $parent]} {
		     puts stderr "winfo toplevel $parent ==> [winfo toplevel $parent]"
		     error "***FATAL: -parent $parent specifies a non-Toplevel widget"
		     exit
		 }
	     } else {
		 incr idx
	     }
	     variable nextwidget
	     set nextwidget 0
	     set name [string range "[lindex $switches [expr {1+$idx}]].[GetName]" 1 end]
	     if {$idx > 0} {
		 set pfx [lrange $switches 0 [expr {$idx-1}]]
	     } else {
		 set pfx {}
	     }
	     if {$idx < [expr {[llength $switches]-1}]} {
		 set sfx [lrange $switches [expr {$idx+2}] end]
	     } else {
		 set sfx {}
	     }
	     set switches [eval {lappend $pfx} $sfx]
	 } elseif {[string compare -nocase $label help] == 0} {
	     set name help
	 } else {
	     set name [ GetName ]
	 }

	 # check to see if menu is on menubar or is cascade
	 # from pulldown and create owner accordingly
	 set pathname [::mm::stack::pathname stack]
 # 	puts "name => $name"
 # 	puts "pathname => $pathname"
	 if { [ ::mm::stack::height stack ] == 0 } {
	     ::mm::stack::push stack $name
 # 	    frame [ ::mm::stack::pathname stack ] -relief raised -borderwidth 3 -height 30 -width 300
 # 	    pack  [ ::mm::stack::pathname stack ] -side left -fill x -side top
	     eval {menu [ ::mm::stack::pathname stack ]  -tearoffcommand [namespace code TearOffControl ]} $switches
	     set parent [ winfo parent [ ::mm::stack::pathname stack ] ]
	     $parent config -menu [ ::mm::stack::pathname stack ]
	     # eval {[ ::mm::stack::pathname stack ] add cascade -label $label -menu [ ::mm::stack::pathname stack ].$name} $switches
	 } else {
 #  	    if { [ ::mm::stack::height stack ] == 1 } {
 #  		::mm::stack::push stack $name
 #  		eval {menubutton [ ::mm::stack::pathname stack ] -menu [ ::mm::stack::pathname stack ].menu -text $label} $switches
 # 		if {[string compare $name help] == 0} {
 # 		    pack [ ::mm::stack::pathname stack ] -side right -fill x
 # 		} else {
 # 		    pack [ ::mm::stack::pathname stack ] -side left -fill x
 # 		}
 #  		::mm::stack::push stack menu
 #  		menu [ ::mm::stack::pathname stack ] -tearoffcommand [ namespace code TearOffControl ]
 #  	    } else {
		 menu [ ::mm::stack::pathname stack ].$name -tearoffcommand [namespace code TearOffControl ]
		 eval {[ ::mm::stack::pathname stack ] add cascade -label $label -menu [ ::mm::stack::pathname stack ].$name} $switches
		 ::mm::stack::push stack $name
 # 	    }
	 }

	 eval $body
	 ::mm::stack::pull stack
 #	if { [ ::mm::stack::height stack ] == 2 } {
 #	    ::mm::stack::pull stack
 #	}
 #	if { [ ::mm::stack::height stack ] == 0 } { mm update }

     } elseif { "$keyword" == "func" } {
	 # mm func - defines a function a menu can refer to

 # 	if { [ ::mm::stack::height stack ] < 3 } {
 # 	    error "***FATAL: func must occur within menu"
 # 	    exit
 # 	}
	 set when ""
	 # puts "args => $args"
	 set rest [DoSwitches args]
	 eval {[ ::mm::stack::pathname stack ] add command} $rest
	 SaveControl [ ::mm::stack::pathname stack ] $when [ [ ::mm::stack::pathname stack ] index end ]

     } elseif { "$keyword" == "toggle" } {
	 # mm toggle - insert a settable boolean in menu

	 set when ""
	 set var ""
	 set cmd ""
	 set init 0
	 set rest [DoSwitches args]
	 eval {[ ::mm::stack::pathname stack ] add checkbutton -variable \
		   $var -onvalue 1 -offvalue 0 -selectcolor black} $rest
	 if {$var == "" } {
	     if {[set idx [lsearch $rest -variable]] >= 0} {
		 set var [lindex $rest [expr {$idx+1}]]
	     } else {
		 error "-init specified, but no variable named"
	     }
	 }
	 uplevel \#0 set $var $init
	 SaveControl [ ::mm::stack::pathname stack ] $when [ [ ::mm::stack::pathname stack ] index end ]

     } elseif { "$keyword" == "check" } {
	 # mm check - insert a radio selector in menu

	 set when ""
	 set var ""
	 set cmd ""
	 set init 0
	 set rest [DoSwitches args]
	 eval {[ ::mm::stack::pathname stack ] add radiobutton -variable \
		   $var -value $label -selectcolor black} $rest
	 if { $init } {
	     if {$var == "" } {
		 if {[set idx [lsearch $rest -variable]] >= 0} {
		     set var [lindex $rest [expr {$idx+1}]]
		 } else {
		     error "-init specified, but no variable named"
		 }
	     }
	     if {[set idx [lsearch $rest -value]] >= 0} {
		 uplevel \#0 set $var [lindex $rest [expr {$idx+1}]]
	     } else {
		 uplevel \#0 set $var \{$label\}
	     }
	 }
	 SaveControl [ ::mm::stack::pathname stack ] $when [ [ ::mm::stack::pathname stack ] index end ]

     } elseif { "$keyword" == "separator" } {
	 # mm separator - inserts a horizontal rule in menu

	 [ ::mm::stack::pathname stack ] add separator

     } elseif { "$keyword" == "control" } {
	 # mm control - puts a non-menu widget under mm state control

	 set widget [ First args ]
	 set when ""
	 set cmd ""
	 DoSwitches args
	 SaveControl $widget $when ""
	 mm update

     } elseif { "$keyword" == "update" }	{
	 # mm update - updates all controlled widgets according to
	 # state control expressions current values.

	 set max [ ::mm::stack::height funclist ]
	 for { set i 0 } { $i < $max } { incr i } {
	     set this_menu [ lindex $menulist $i ]
	     set ctrl [ lindex $funclist $i ]
	     set index [ lindex $indxlist $i ]
	     set active 1
	     if { "$ctrl" != "" } {
		 set active [ uplevel \#0 expr $ctrl ]
	     }
	     if { "$index" == "" } {
		 if { $active } {
		     $this_menu configure -state normal
		 } else {
		     $this_menu configure -state disabled
		 }
	     } else {
		 foreach widget $this_menu {
		     SetState $active $widget $index
		     set torn [ GetTearOffs $widget ]
		     if { "$torn" != "" } {
			 foreach w $torn {
			     set result [ catch { SetState $active $w [ expr $index - 1 ] } ]
			     if { $result != 0 } {
				 DeleteTearOffs $widget $w
			     }
			 }
		     }
		 }
	     }
	 }
     }
     update
 }

Below is the example code from Menus Even Easier with the following changes:

  • package require since the new code is a proper Tcl package
  • namespace import to get the mm command in the global namespace as before
  • all occurrences of -cmd have been changed to -command
 package require tkMenuMgr
 namespace import ::mm::*

 set fileopen 0
 set filemod  0

 mm menu Top {
   mm menu File {
     mm func {
       -label "New"
       -command { set fileopen 1; mm update }
       -when { !$fileopen }
     }
     mm func {
       -label "Open..."
       -command { set fileopen 1; mm update }
       -when { !$fileopen }
     }
     mm separator
     mm func {
       -label "Save"
       -when { $fileopen && $filemod }
       -command { set filemod 0; mm update }
     }
     mm func {
       -label "Save As..."
       -when { $fileopen && $filemod  }
       -command { set filemod 0; mm update }
       }
     mm func {
       -label "Close"
       -when { $fileopen }
       -command { set fileopen 0; mm update }
     }
     mm separator
     mm func -label "Quit" -command { exit }
   }
   mm menu Test {
     mm func {
       -label "Modify State"
       -command { set filemod 1; mm update }
     }
     mm separator
     mm check {
       -label "First"
       -var selection
     }
     mm check {
       -label "Second"
       -var selection
       -init 1
     }
     mm check {
       -label "Third"
       -var selection
     }
   }
   mm menu Options {
     mm toggle {
       -label "Flag 1"
       -var flag1
       -init 1
     }
     mm toggle  {
       -label "Flag 2"
       -var flag2
       -init 0
     }
   }
 }

 while 1 {
   vwait selection
   puts "selection is now: $selection"
 }

DKF - Making accelerators work automatically is non-trivial; getting the mapping between characters and keys is very tricky indeed! However, I've found that it is easier if you go from the binding to the accelerator string, and not the other way round. You can then even do tricks like making the bindings be to virtual events (like <<Paste>>) and then pick up the correct platform defaults that Tk picks out for you. Which is a very neat trick indeed!s

RBR - This one non-obvious idiom I've encountered using this code. If you want to stick in a place-holder menu item that is non-functional and you want it to be disabled (a la -state disabled), then you do not use -state disabled. Instead use -when 0. This is because mm update walks through it's list of variables and will enable all menus which do not have a -when clause.

Category GUI - Arts and crafts of Tcl-Tk programming