MC, 14 May 2003: Along the lines of Visual menus, Menus made easy, Menus Even Easier and Menus Even Easier Redux, pdmenus is a small package to describe Tk pulldown menus in XML (using tDOM). I've attempted to keep this page reapable with wish-reaper. The package is also available via CVS[L1 ].
First, here is what the example menu from Menus made easy looks like translated into our pdmenus XML dialect:
set xml {
<menu name=".m" parent=".">
<menu name=".m.file" label="*File" tearoff="0">
<command label="*Open">
<code>openFile</code>
</command>
<command label="*Save">
<code>saveAs known</code>
</command>
<command label="Save *As ...">
<code>saveAs</code>
</command>
<separator />
<command label="*Quit">
<code>exit</code>
</command>
</menu>
<menu name=".m.edit" label="*Edit" tearoff="0">
<command label="Cut">
<code>doCut</code>
</command>
<menu name=".m.edit.copy" label="Copy" tearoff="0">
<command label="foo">
<code>puts foo</code>
</command>
<command label="bar">
<code>puts bar</code>
</command>
<command label="grill">
<code>puts grill</code>
</command>
</menu>
<command label="*Paste">
<code>doPaste</code>
</command>
</menu>
</menu>
}Here is the DTD describing our markup language for pull down menus:
set DTD {
<!DOCTYPE menu [
<!ELEMENT menu (menu | command | separator | radio)*>
<!ELEMENT command (binding*, code?, test?)>
<!ELEMENT radio (binding*, code?, test?)>
<!ELEMENT separator EMPTY>
<!ELEMENT binding (#PCDATA)>
<!ELEMENT code (#PCDATA)>
<!ELEMENT test (#PCDATA)>
<!ATTLIST menu name NMTOKEN #REQUIRED
label CDATA #IMPLIED
parent CDATA #IMPLIED
tearoff CDATA #IMPLIED
varray NMTOKEN #IMPLIED>
<!ATTLIST command label CDATA #REQUIRED
accelerator CDATA #IMPLIED>
<!ATTLIST separator>
<!ATTLIST radio label CDATA #REQUIRED
var NMTOKEN #REQUIRED
value CDATA #REQUIRED
default NMTOKEN #IMPLIED>
<!ATTLIST binding>
<!ATTLIST code>
<!ATTLIST test>
]>
}And the actual code that makes everything happen:
#-------------------------------------------------------------------------------
#
# PULL DOWN MENUS via XML
#
# PURPOSE:
#
# Implement pull down menus, based on an XML definition.
#
# METHODS:
#
# $menu VerifyStates
# Private method called when a menu is posted to run through the menu's
# tests to see which items should be in a clickable state.
#
# $menu CalcUnderline
# Private method that returns the position of an asterisk in a label
# and then the label without the asterisk.
#
# $menu loadFromXML xml
# Create a menu based on an XML description.
#
#-------------------------------------------------------------------------------
namespace eval ::pdmenu {
package require Tcl 8.3
package require Tk 8.3
package require tdom 0.7.5
}
proc ::pdmenu::CalcUnderline label {
return [list [string first * $label] [string map {* {}} $label]]
}
proc ::pdmenu::VerifyStates handle {
variable $handle
upvar 0 $handle menu
set counter 0
foreach test $menu(tests) {
if {[string length $test]} {
if {[expr $test] == 1} {
$menu(hull) entryconfigure $counter -state normal
} else {
$menu(hull) entryconfigure $counter -state disabled
}
}
incr counter
}
}
proc ::pdmenu::loadFromXML xml {
set doc [dom parse $xml]
set root [$doc documentElement]
set handle [$root getAttribute name]
variable $handle
upvar 0 $handle menu
upvar 0 menu(tests) tests
set menu(hull) $handle
if {[llength [info commands $handle]] == 0} {
menu $menu(hull) -postcommand [list ::pdmenu::VerifyStates $handle] \
-tearoff [$root getAttribute tearoff 0]
}
set tests [list]
set varray [$root getAttribute varray ""]
if {[$root hasAttribute parent]} {
[$root getAttribute parent] configure -menu $menu(hull)
}
foreach item [$root selectNodes *] {
set type [$item nodeName]
set node [$item selectNodes code/text()]
if {$node != ""} {
set code [$node data]
foreach node [$item selectNodes binding/text()] {
bind . <[$node data]> $code
}
} else {
set code {}
}
set node [$item selectNodes test/text()]
if {$node != ""} {
lappend tests [$node data]
} else {
lappend tests {}
}
set accel [$item getAttribute accelerator ""]
set label [$item getAttribute label ""]
foreach {pos label} [CalcUnderline $label] break
switch -exact -- $type {
menu {
set name [$item getAttribute name]
$menu(hull) add cascade -label $label \
-menu $name \
-underline $pos
::pdmenu::loadFromXML [$item asXML]
}
command {
$menu(hull) add command -label $label \
-command $code \
-accel $accel \
-underline $pos
}
radio {
set var [string trim ${varray}([$item getAttribute var]) ()]
set value [$item getAttribute value]
if {[$item hasAttribute default] &&
[string is true -strict [$item getAttribute default]]} {
set ::$var $value
}
$menu(hull) add radiobutton -label $label \
-command $code \
-value $value \
-accelerator $accel \
-variable $var
}
separator {
$menu(hull) add separator
}
default {
error "Unknown menu entry type \"$type\""
}
}
}
$doc delete
}
#-------------------------------------------------------------------------------
# Initilization
package provide pdmenus 1.0And now, to make our example menu:
pdmenu::loadFromXML $xml
TODO: add checkbuttons.