# 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.
#
#################################################################
# #
# __ _ _ _ _ #
# / _\ |_ __ _ ___| | _____ /\/\ ___ __| |_ _| | ___ #
# \ \| __/ _` |/ __| |/ / __| / \ / _ \ / _` | | | | |/ _ \ #
# _\ \ || (_| | (__| <\__ \ / /\/\ \ (_) | (_| | |_| | | __/ #
# \__/\__\__,_|\___|_|\_\___/ \/ \/\___/ \__,_|\__,_|_|\___| #
# #
#################################################################
proc height { stack } {
upvar $stack s
return [ llength $s ]
}
proc push { stack str } {
upvar $stack s
lappend s $str
}
proc pull { stack } {
upvar $stack s
if { $s == "" } return ""
set result [ lindex $s end ]
set s [ lreplace $s end end ]
return $result
}
proc 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 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 pushpath { stack pathname { separator "." } } {
upvar $stack s
set s [ split $pathname $separator ]
if { [ lindex $s 0 ] == "" } { set s [ lreplace $s 0 0 ] }
}
#################################################################
# #
# _ _ #
# /\/\ ___ _ __ _ _ /\/\ ___ __| |_ _| | ___ #
# / \ / _ \ '_ \| | | | / \ / _ \ / _` | | | | |/ _ \ #
# / /\/\ \ __/ | | | |_| | / /\/\ \ (_) | (_| | |_| | | __/ #
# \/ \/\___|_| |_|\__,_| \/ \/\___/ \__,_|\__,_|_|\___| #
# #
#################################################################
set stack ""
set funclist ""
set menulist ""
set indxlist ""
set nextwidget 0
# returns a string for the next widget name
proc getname { } {
global 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 do_switches { 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 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 tearoffctrl { parent newwidget } {
global torn
if { [ info exists torn($parent) ] == 0 } {
set torn($parent) ""
}
push torn($parent) $newwidget
}
# returns list of menus torn off of this main one.
proc get_tearoffs { parent } {
global torn
if { [ info exists torn($parent) ] == 1 } {
return $torn($parent)
} else {
return ""
}
}
# removes a torn-off menu that no longer exists.
proc del_tearoffs { parent w } {
global torn
set i [ lsearch -exact $torn($parent) $w ]
# RBR 2002-11-19: added missing "set torn()..." to fix buglet
set torn($parent) [lreplace torn($parent) $i $i]
}
proc setstate { active widget index } {
if { $active } {
$widget entryconfigure $index -state normal
} else {
$widget entryconfigure $index -state disabled
}
}
proc savectrl { widget when index } {
global menulist funclist indxlist
push menulist $widget
push funclist $when
push indxlist $index
}
# the menu mgr proper
proc mm { keyword args } {
global stack menulist funclist 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 { [ height stack ] == 0 } {
push stack $name
frame [ pathname stack ] -relief raised -borderwidth 3 -height 30 -width 300
pack [ pathname stack ] -side left -fill x -side top
} else {
if { [ height stack ] == 1 } {
push stack $name
menubutton [ pathname stack ] -menu [ pathname stack ].menu -text "$label"
pack [ pathname stack ] -side left -fill x
push stack menu
menu [ pathname stack ] -tearoffcommand { tearoffctrl }
} else {
menu [ pathname stack ].$name -tearoffcommand { tearoffctrl }
[ pathname stack ] add cascade -label $label -menu [ pathname stack ].$name
push stack $name
}
}
eval set body $args
set body [ string range $body 1 [ expr [ string length $body ] - 1 ] ]
eval $body
pull stack
if { [ height stack ] == 2 } {
pull stack
}
if { [ height stack ] == 0 } { mm update }
# mm func - defines a function a menu can refer to
} elseif { "$keyword" == "func" } {
if { [ height stack ] < 3 } {
puts "***FATAL: func must occur within menu"
exit
}
set when ""
set cmd ""
do_switches args
[ pathname stack ] add command -label $label -command $cmd
savectrl [ pathname stack ] $when [ [ pathname stack ] index end ]
# mm toggle - insert a settable boolean in menu
} elseif { "$keyword" == "toggle" } {
set when ""
set var ""
set cmd ""
set init 0
do_switches args
[ pathname stack ] add checkbutton -label $label -variable \
$var -command $cmd -onvalue 1 -offvalue 0 -selectcolor black
uplevel #0 set $var $init
savectrl [ pathname stack ] $when [ [ pathname stack ] index end ]
# mm check - insert a radio selector in menu
} elseif { "$keyword" == "check" } {
set when ""
set var ""
set cmd ""
set init 0
do_switches args
[ pathname stack ] add radiobutton -label $label -variable \
$var -command $cmd -value $label -selectcolor black
if { $init } {
uplevel #0 set $var $label
}
savectrl [ pathname stack ] $when [ [ pathname stack ] index end ]
# mm separator - inserts a horizontal rule in menu
} elseif { "$keyword" == "separator" } {
[ 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 ""
do_switches args
savectrl $widget $when ""
mm update
# mm update - updates all controlled widgets according to
# state control expressions current values.
} elseif { "$keyword" == "update" } {
set max [ 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 [ get_tearoffs $widget ]
if { "$torn" != "" } {
foreach w $torn {
set result [ catch { setstate $active $w [ expr $index - 1 ] } ]
if { $result != 0 } {
del_tearoffs $widget $w
}
}
}
}
}
}
}
update
}and here's a test program to show how it works. source tkMenuMgr.tcl
set fileopen 0
set filemod 0
mm menu Top {
mm menu File {
mm func {
-label "New"
-cmd { set fileopen 1; mm update }
-when { !$fileopen }
}
mm func {
-label "Open..."
-cmd { set fileopen 1; mm update }
-when { !$fileopen }
}
mm separator
mm func {
-label "Save"
-when { $fileopen && $filemod }
-cmd { set filemod 0; mm update }
}
mm func {
-label "Save As..."
-when { $fileopen && $filemod }
-cmd { set filemod 0; mm update }
}
mm func {
-label "Close"
-when { $fileopen }
-cmd { set fileopen 0; mm update }
}
mm separator
mm func -label "Quit" -cmd { exit }
}
mm menu Test {
mm func {
-label "Modify State"
-cmd { 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"
}RBR - For a version of this that uses namespaces, see Menus Even Easier Redux
