tkMenuMgr is a module that greatly simplifies
the drudgery of ''properly'' handling menus and
menubars.  It provides an easy way to handle
enabling and disabling menu items according to
your program's state, and keeps torn-off menus
in sync with those on the menu bar.  It can also
enable or disable arbitrary widgets not part of
the menu hierarchy.

Here's the module:

 # 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]
----
[Arts and crafts of Tcl-Tk programming]