/[webpac]/openisis/current/tcl/lib/mlcm.menu.tcl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /openisis/current/tcl/lib/mlcm.menu.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 237 - (show annotations)
Mon Mar 8 17:43:12 2004 UTC (18 years, 5 months ago) by dpavlin
File MIME type: application/x-tcl
File size: 3437 byte(s)
initial import of openisis 0.9.0 vendor drop

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

  ViewVC Help
Powered by ViewVC 1.1.26