git.rot13.org Git - webpac/blob - openisis/tcl/lib/mlcm.menu.tcl

   1
   2 package provide mlcm::menu 0.1
   3
   4 namespace eval mlcm::menu {
   5
   6         array set _all {}
   7         array set _men {}
   8         set _act 0
   9
  10         proc addentry {name rec}  {
  11                 variable _all
  12                 if [catch {set menus $_all($name)}] {
  13                         set menus [list]
  14                 }
  15                 set len  [llength $menus]
  16                 set ent  [$rec get 3000]
  17                 set idx  [expr $ent / 100]
  18                 for {set j $len} {$idx >= $j} {incr j} {
  19                         lappend menus [list]
  20                 }
  21                 set lst [lindex $menus $idx]
  22                 set cfg [openIsisRec {} -fdt $mlcm::meta::fdtMenu]
  23                 eval $cfg add -ignore [$rec get -tags]
  24                 $rec done
  25                 lappend lst $cfg
  26                 lset menus $idx $lst
  27                 set _all($name) $menus
  28         }
  29
  30         proc _sortentries {e1 e2} {
  31                 set m1 [$e1 get 3000]
  32                 set m2 [$e2 get 3000]
  33                 expr $m1 - $m2
  34         }
  35
  36         proc doneentries {} {
  37                 variable _all
  38                 foreach {key lst} [array get _all] {
  39                         set len [llength $lst]
  40                         set slst [list]
  41                         for {set j 0} {$len > $j} {incr j} {
  42                                 set ent [lindex $lst $j]
  43                                 if [llength $ent] {
  44                                         set ent [lsort -command _sortentries $ent]
  45                                 }
  46                                 lappend slst "$ent"
  47                         }
  48                         set _all($key) $slst
  49                 }
  50         }
  51
  52         proc _name2lbl {name underl} {
  53                 upvar $underl idx
  54                 set idx [string first & $name]
  55                 if {0 <= $idx} {
  56                         set res [string range $name [expr $idx + 1] end]
  57                         if $idx {
  58                                 set n1 [string range $name 0 [expr $idx - 1]]
  59                                 set res $n1$res
  60                         }
  61                         set idx "-underline $idx"
  62                         return $res
  63                 }
  64                 set idx ""
  65                 return $name
  66         }
  67
  68         proc _rec2btn rec {
  69                 set name [_name2lbl [mlcm::lang::strippedMsg [$rec get name\[0\]]] underl]
  70                 return "-text $name $underl"
  71         }
  72
  73         proc _rec2cmd rec {
  74                 set name [_name2lbl [mlcm::lang::strippedMsg [$rec get name\[0\]]] underl]
  75                 set cmd [$rec get {command\[0\] {}}]
  76                 if [string length $cmd] {
  77                         set cmd "-command \{$cmd\}"
  78                 }
  79                 set act [$rec get {active\[0\] 1}]
  80                 if [eval expr $act] {
  81                         set act ""
  82                 } {
  83                         set act "-state disabled"
  84                 }
  85                 return "-label \"$name\" $underl $cmd $act"
  86         }
  87
  88         proc _test {} {
  89                 variable _act
  90                 set _act [ expr ! $_act ]
  91         }
  92
  93         proc showmenu {name parent} {
  94                 variable _all
  95                 variable _men
  96                 set j 0
  97                 foreach lst $_all($name) {
  98                         set len [llength $lst]
  99                         if $len {
 100                                 set rec [lindex $lst 0]
 101                                 set bttn $parent.$j
 102                                 set subm $bttn.sub
 103                                 set opts [_rec2btn $rec]
 104                                 eval menubutton $bttn $opts \
 105                                         -menu $subm -bd 2 -relief flat
 106                                 pack $bttn -side left
 107                                 menu $subm -tearoff 0 -borderwidth 2
 108                                 for {set s 1} {$len > $s} {incr s} {
 109                                         set rec [lindex $lst $s]
 110                                         set opts [_rec2cmd $rec]
 111                                         eval $subm add command $opts
 112                                 }
 113                         }
 114                         incr j
 115                 }
 116                 if $j {
 117                         set _men("$parent\ $name") $j
 118                 }
 119         }
 120
 121         proc notify {name parent} {
 122                 variable _all
 123                 variable _men
 124                 if {0 == [string length $name]} {
 125                         set name *
 126                 }
 127                 if {0 == [string length $parent]} {
 128                         set parent *
 129                 }
 130                 foreach {key maxm} [array get _men "\"$parent\ $name\""] {
 131                         set parent [eval lindex $key 0]
 132                         set name [eval lindex $key 1]
 133                         if ![llength [info command $parent]] {
 134                                 puts "mlcm::menu: removing $parent"
 135                                 array unset _men $key
 136                                 continue
 137                         }
 138                         set j 0
 139                         foreach lst $_all($name) {
 140                                 set len [llength $lst]
 141                                 if $len {
 142                                         set subm $parent.$j.sub
 143                                         for {set s 1} {$len > $s} {incr s} {
 144                                                 set rec [lindex $lst $s]
 145                                                 set act [$rec get {active\[0\] 1}]
 146                                                 if [eval expr $act] {
 147                                                         set stn normal
 148                                                 } {
 149                                                         set stn disabled
 150                                                 }
 151                                                 set s1  [expr $s - 1]
 152                                                 set sto [$subm entrycget $s1 -state]
 153                                                 if ![string equal $sto $stn] {
 154                                                         $subm entryconfigure $s1 -state $stn
 155                                                 }
 156                                         }
 157                                 }
 158                                 incr j
 159                         }
 160                 }
 161         }
 162 }
 163