| ︙ | | |
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
-
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
+
-
+
-
+
-
+
-
-
+
+
|
"&Debug" {
"Reread &Source" -acc F1 -cmd _rs
}
}
}
# Main call for psmenu. Optional arguments are for internal use.
proc psmenu::psmenu {top def {Toplevel ""} {Level ""}} {
proc psmenu::psmenu {top args} {
set def [lindex $args end]
set args [lrange $args 0 end-1]
set opts(-top) ""
set opts(-level) ""
set opts(-level) ""
set opts(-recursive) 0
array set opts $args
# Is given arg a toplevel or menu?
if {$top eq "."} {
set m .m
} else {
if {[winfo class $top] ne "Menu"} {
set m $top.m
}
if {$Toplevel ne ""} {
set m $top.m
} else {
# A menu was given, assume -top
set m $top
set top $opts(-top)
}
}
if {$opts(-recursive)} {
# Locate a free window name for the menu, for internal call
while {[winfo exists $m]} {
if {[regexp {^(.*?)(\d+)$} $m -> prefix index]} {
incr index
} else {
set prefix $m
set index 0
}
set m $prefix$index
}
}
# It might exists for a second user call
# It might exist for a second user call
if { ! [winfo exists $m]} {
# Create
menu $m -tearoff 0
}
if {$Level eq ""} {
if {$opts(-level) eq ""} {
# Store initial level to handle scope when recursing cascades
set Level [uplevel 1 info level]
set opts(-level) [uplevel 1 info level]
}
if {$Toplevel eq ""} {
set Toplevel $top
if {$opts(-top) eq ""} {
set opts(-top) $top
$top configure -menu $m
}
# Comments in definition block
set def [regsub -all -line {^\s*#.*$} $def ""]
set state ""
|
| ︙ | | |
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
-
+
-
+
|
# Conditionals
if {$label eq "if"} {
# TBD support elseif
set ifExpr [lindex $entry 1]
set body [lindex $entry 2]
set elseBody [lindex $entry 4]
set cond [uplevel \#$Level [list expr $ifExpr]]
set cond [uplevel \#$opts(-level) [list expr $ifExpr]]
#puts "if expression '$ifExpr' = $cond"
if {$cond} {
# Prepend
set def [list {*}$body {*}$def]
} elseif {$elseBody ne ""} {
set def [list {*}$elseBody {*}$def]
}
continue
}
# Recognise Cascade by even args "Name ?opts? Def"
# An item will be "Name ?opts?", i.e odd
if {[llength $entry] % 2 == 0} {
# Cascade
set options [lrange $entry 1 end-1]
set body [lindex $entry end]
# Recurse cascade defintion
set cascade [psmenu $m $body $Toplevel $Level]
set cascade [psmenu $m {*}[array get opts] -recursive 1 $body]
# Since -menu is last, processing below can assume that.
lappend options -menu $cascade
} else {
set options [lrange $entry 1 end]
}
#puts "Label '$label'"
#puts "Options '$options'"
|
| ︙ | | |
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
-
+
|
set doBind ""
set command ""
set value ""
set variable ""
set cfgvar ""
set default 0
foreach {opt val} $options {
set val [uplevel \#$Level [list subst $val]]
set val [uplevel \#$opts(-level) [list subst $val]]
switch -- $opt {
-ul - -underline {
lappend newOptions -underline $val
}
-var - -variable {
if {$type eq "cascade"} {
set variable $val
|
| ︙ | | |
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
|
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
|
-
+
-
+
-
+
-
+
|
}
-onvalue {
lappend newOptions -onvalue $val
}
-menu {
lappend newOptions -menu $val
if {$variable ne ""} {
uplevel \#$Level [list set $variable $val]
uplevel \#$opts(-level) [list set $variable $val]
}
}
-def {
set default $val
}
default {
# Just let through
lappend newOptions $opt $val
}
}
}
if {$variable ne ""} {
upvar \#$Level $variable __vv
upvar \#$opts(-level) $variable __vv
if {![info exists __vv]} {
set __vv $default
}
}
# TK helper to handle & in label
::tk::AmpMenuArgs $m add $type {*}$newOptions
if {$cfgvar ne ""} {
set ix [$m index end]
set tmp [list $m entryconfigure $ix]
uplevel \#$Level [list set $cfgvar $tmp]
uplevel \#$opts(-level) [list set $cfgvar $tmp]
}
if {$doBind ne ""} {
if {[regexp {^(.*)-(.*)$} $doBind -> pre post]} {
if {$pre eq "Ctrl"} {
set pre "Control"
}
set doBind $pre-Key-$post
} else {
set doBind Key-$doBind
}
#puts "Binding '$doBind' '$command'"
bind $Toplevel <$doBind> $command
bind $opts(-top) <$doBind> $command
}
}
return $m
}
# Extract one entry from definiton
|
| ︙ | | |