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::*" which will import only the mm command itself.
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 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.
proc ::mm::DoSwitches { args } {
upvar $args arglist
set max [ llength $arglist ]
if { $max == 1 } {
# braced set of args
eval set arglist $arglist
set max [ llength $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\}
continue
}
}
uplevel 1 set $var 1
}
incr i
}
}
# 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" } {
return ".w0"
# mm menu - defines a new menu
} elseif { "$keyword" == "menu" } {
set label [ First args ]
# check to see if menu is on menubar or is cascade
# from pulldown and create owner accordingly
set name [ GetName ]
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
} else {
if { [ ::mm::stack::height stack ] == 1 } {
::mm::stack::push stack $name
menubutton [ ::mm::stack::pathname stack ] -menu [ ::mm::stack::pathname stack ].menu -text "$label"
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 ]
[ ::mm::stack::pathname stack ] add cascade -label $label -menu [ ::mm::stack::pathname stack ].$name
::mm::stack::push stack $name
}
}
eval set body $args
set body [ string range $body 1 [ expr [ string length $body ] - 1 ] ]
eval $body
::mm::stack::pull stack
if { [ ::mm::stack::height stack ] == 2 } {
::mm::stack::pull stack
}
if { [ ::mm::stack::height stack ] == 0 } { mm update }
# mm func - defines a function a menu can refer to
} elseif { "$keyword" == "func" } {
if { [ ::mm::stack::height stack ] < 3 } {
error "***FATAL: func must occur within menu"
exit
}
set when ""
set cmd ""
DoSwitches args
[ ::mm::stack::pathname stack ] add command -label $label -command $cmd
SaveControl [ ::mm::stack::pathname stack ] $when [ [ ::mm::stack::pathname stack ] index end ]
# mm toggle - insert a settable boolean in menu
} elseif { "$keyword" == "toggle" } {
set when ""
set var ""
set cmd ""
set init 0
DoSwitches args
[ ::mm::stack::pathname stack ] add checkbutton -label $label -variable \
$var -command $cmd -onvalue 1 -offvalue 0 -selectcolor black
# The \#0 is to keep Emacs' indentation parser happy. It
# incorrectly thinks the hash marks starts a comment and further
# doesn't count brackets inside comments.
uplevel \#0 set $var $init
SaveControl [ ::mm::stack::pathname stack ] $when [ [ ::mm::stack::pathname stack ] index end ]
# mm check - insert a radio selector in menu
} elseif { "$keyword" == "check" } {
set when ""
set var ""
set cmd ""
set init 0
DoSwitches args
[ ::mm::stack::pathname stack ] add radiobutton -label $label -variable \
$var -command $cmd -value $label -selectcolor black
if { $init } {
uplevel \#0 set $var $label
}
SaveControl [ ::mm::stack::pathname stack ] $when [ [ ::mm::stack::pathname stack ] index end ]
# mm separator - inserts a horizontal rule in menu
} elseif { "$keyword" == "separator" } {
[ ::mm::stack::pathname stack ] add separator
# mm control - puts a non-menu widget under mm state control
} elseif { "$keyword" == "control" } {
set widget [ First args ]
set when ""
set cmd ""
DoSwitches args
SaveControl $widget $when ""
mm update
# mm update - updates all controlled widgets according to
# state control expressions current values.
} elseif { "$keyword" == "update" } {
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
}