mailto:[email protected]

 #
 # Copyright © 2002, Larry Smith
 # Copyright © 2002–2003 Roland B. Roberts <[email protected]>
 #
 # 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
 }

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

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References