[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 pulldown menus in XML (using [tDOM]).  I've attempted to keep this page ''reapable'' with [wish-reaper].  The package is also available via CVS[http://sourceforge.net/cvs/?group_id=63662].

First, here is what the example menu from [Menus made easy] looks like:

 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.0

And now, to make our example menu:

 pdmenu::loadFromXML $xml

TODO: add checkbuttons.