/[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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 237 - (hide 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 dpavlin 237
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