# 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
 }

 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"
 }