Mercurial > repos > rliterman > csp2

comparison CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/itcl4.2.3/itclWidget.tcl @ 69:33d812a61356

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
planemo upload commit 2e9511a184a1ca667c7be0c6321a36dc4e3d116d
author jpayne
date Tue, 18 Mar 2025 17:55:14 -0400
parents
children
comparison
equal deleted inserted replaced
67:0e9998148a16 69:33d812a61356
1 #
2 # itclWidget.tcl
3 # ----------------------------------------------------------------------
4 # Invoked automatically upon startup to customize the interpreter
5 # for [incr Tcl] when one of ::itcl::widget or ::itcl::widgetadaptor is called.
6 # ----------------------------------------------------------------------
7 # AUTHOR: Arnulf P. Wiedemann
8 #
9 # ----------------------------------------------------------------------
10 # Copyright (c) 2008 Arnulf P. Wiedemann
11 # ======================================================================
12 # See the file "license.terms" for information on usage and
13 # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14
15 package require Tk 8.6
16 # package require itclwidget [set ::itcl::version]
17
18 namespace eval ::itcl {
19
20 proc widget {name args} {
21 set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args]
22 # we handle create by owerselfs !! allow classunknown to handle that
23 oo::objdefine $result unexport create
24 return $result
25 }
26
27 proc widgetadaptor {name args} {
28 set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args]
29 # we handle create by owerselfs !! allow classunknown to handle that
30 oo::objdefine $result unexport create
31 return $result
32 }
33
34 } ; # end ::itcl
35
36
37 namespace eval ::itcl::internal::commands {
38
39 proc initWidgetOptions {varNsName widgetName className} {
40 set myDict [set ::itcl::internal::dicts::classOptions]
41 if {$myDict eq ""} {
42 return
43 }
44 if {![dict exists $myDict $className]} {
45 return
46 }
47 set myDict [dict get $myDict $className]
48 foreach option [dict keys $myDict] {
49 set infos [dict get $myDict $option]
50 set resource [dict get $infos -resource]
51 set class [dict get $infos -class]
52 set value [::option get $widgetName $resource $class]
53 if {$value eq ""} {
54 if {[dict exists $infos -default]} {
55 set defaultValue [dict get $infos -default]
56 uplevel 1 set ${varNsName}::itcl_options($option) $defaultValue
57 }
58 } else {
59 uplevel 1 set ${varNsName}::itcl_options($option) $value
60 }
61 }
62 }
63
64 proc initWidgetDelegatedOptions {varNsName widgetName className args} {
65 set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
66 if {$myDict eq ""} {
67 return
68 }
69 if {![dict exists $myDict $className]} {
70 return
71 }
72 set myDict [dict get $myDict $className]
73 foreach option [dict keys $myDict] {
74 set infos [dict get $myDict $option]
75 if {![dict exists $infos -resource]} {
76 # this is the case when delegating "*"
77 continue
78 }
79 if {![dict exists $infos -component]} {
80 # nothing to do
81 continue
82 }
83 # check if not in the command line options
84 # these have higher priority
85 set myOption $option
86 if {[dict exists $infos -as]} {
87 set myOption [dict get $infos -as]
88 }
89 set noOptionSet 0
90 foreach {optName optVal} $args {
91 if {$optName eq $myOption} {
92 set noOptionSet 1
93 break
94 }
95 }
96 if {$noOptionSet} {
97 continue
98 }
99 set resource [dict get $infos -resource]
100 set class [dict get $infos -class]
101 set component [dict get $infos -component]
102 set value [::option get $widgetName $resource $class]
103 if {$component ne ""} {
104 if {$value ne ""} {
105 set compVar [namespace eval ${varNsName}${className} "set $component"]
106 if {$compVar ne ""} {
107 uplevel 1 $compVar configure $myOption $value
108 }
109 }
110 }
111 }
112 }
113
114 proc widgetinitobjectoptions {varNsName widgetName className} {
115 #puts stderr "initWidgetObjectOptions!$varNsName!$widgetName!$className!"
116 }
117
118 proc deletehull {newName oldName what} {
119 if {$what eq "delete"} {
120 set name [namespace tail $newName]
121 regsub {hull[0-9]+} $name {} name
122 rename $name {}
123 }
124 if {$what eq "rename"} {
125 set name [namespace tail $newName]
126 regsub {hull[0-9]+} $name {} name
127 rename $name {}
128 }
129 }
130
131 proc hullandoptionsinstall {objectName className widgetClass hulltype args} {
132 if {$hulltype eq ""} {
133 set hulltype frame
134 }
135 set idx 0
136 set found 0
137 foreach {optName optValue} $args {
138 if {$optName eq "-class"} {
139 set found 1
140 set widgetClass $optValue
141 break
142 }
143 incr idx
144 }
145 if {$found} {
146 set args [lreplace $args $idx [expr {$idx + 1}]]
147 }
148 if {$widgetClass eq ""} {
149 set widgetClass $className
150 set widgetClass [string totitle $widgetClass]
151 }
152 set cmd "set win $objectName; ::itcl::builtin::installhull using $hulltype -class $widgetClass $args"
153 uplevel 2 $cmd
154 }
155
156 } ; # end ::itcl::internal::commands
157
158 namespace eval ::itcl::builtin {
159
160 proc installhull {args} {
161 set cmdPath ::itcl::internal::commands
162 set className [uplevel 1 info class]
163
164 set replace 0
165 switch -- [llength $args] {
166 0 {
167 return -code error\
168 "wrong # args: should be \"[lindex [info level 0] 0]\
169 name|using <widgetType> ?arg ...?\""
170 }
171 1 {
172 set widgetName [lindex $args 0]
173 set varNsName $::itcl::internal::varNsName($widgetName)
174 }
175 default {
176 upvar win win
177 set widgetName $win
178
179 set varNsName $::itcl::internal::varNsName($widgetName)
180 set widgetType [lindex $args 1]
181 incr replace
182 if {[llength $args] > 3 && [lindex $args 2] eq "-class"} {
183 set classNam [lindex $args 3]
184 incr replace 2
185 } else {
186 set classNam [string totitle $widgetType]
187 }
188 uplevel 1 [lreplace $args 0 $replace $widgetType $widgetName -class $classNam]
189 uplevel 1 [list ${cmdPath}::initWidgetOptions $varNsName $widgetName $className]
190 }
191 }
192
193 # initialize the itcl_hull variable
194 set i 0
195 set nam ::itcl::internal::widgets::hull
196 while {1} {
197 incr i
198 set hullNam ${nam}${i}$widgetName
199 if {[::info command $hullNam] eq ""} {
200 break
201 }
202 }
203 uplevel 1 [list ${cmdPath}::sethullwindowname $widgetName]
204 uplevel 1 [list ::rename $widgetName $hullNam]
205 uplevel 1 [list ::trace add command $hullNam {delete rename} ::itcl::internal::commands::deletehull]
206 catch {${cmdPath}::checksetitclhull [list] 0}
207 namespace eval ${varNsName}${className} "set itcl_hull $hullNam"
208 catch {${cmdPath}::checksetitclhull [list] 2}
209 uplevel 1 [lreplace $args 0 $replace ${cmdPath}::initWidgetDelegatedOptions $varNsName $widgetName $className]
210 }
211
212 proc installcomponent {args} {
213 upvar win win
214
215 set className [uplevel 1 info class]
216 set myType [${className}::info types [namespace tail $className]]
217 set isType 0
218 if {$myType ne ""} {
219 set isType 1
220 }
221 set numArgs [llength $args]
222 set usage "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?"
223 if {$numArgs < 4} {
224 error $usage
225 }
226 foreach {componentName using widgetType widgetPath} $args break
227 set opts [lrange $args 4 end]
228 if {$using ne "using"} {
229 error $usage
230 }
231 if {!$isType} {
232 set hullExists [uplevel 1 ::info exists itcl_hull]
233 if {!$hullExists} {
234 error "cannot install \"$componentName\" before \"itcl_hull\" exists"
235 }
236 set hullVal [uplevel 1 set itcl_hull]
237 if {$hullVal eq ""} {
238 error "cannot install \"$componentName\" before \"itcl_hull\" exists"
239 }
240 }
241 # check for delegated option and ask the option database for the values
242 # first check for number of delegated options
243 set numOpts 0
244 set starOption 0
245 set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
246 if {[dict exists $myDict $className]} {
247 set myDict [dict get $myDict $className]
248 foreach option [dict keys $myDict] {
249 if {$option eq "*"} {
250 set starOption 1
251 }
252 incr numOpts
253 }
254 }
255 set myOptionDict [set ::itcl::internal::dicts::classOptions]
256 if {[dict exists $myOptionDict $className]} {
257 set myOptionDict [dict get $myOptionDict $className]
258 }
259 set cmd [list $widgetPath configure]
260 set cmd1 "set $componentName \[$widgetType $widgetPath\]"
261 uplevel 1 $cmd1
262 if {$starOption} {
263 upvar $componentName compName
264 set cmd1 [list $compName configure]
265 set configInfos [uplevel 1 $cmd1]
266 foreach entry $configInfos {
267 if {[llength $entry] > 2} {
268 foreach {optName resource class defaultValue} $entry break
269 set val ""
270 catch {
271 set val [::option get $win $resource $class]
272 }
273 if {$val ne ""} {
274 set addOpt 1
275 if {[dict exists $myDict $$optName]} {
276 set addOpt 0
277 } else {
278 set starDict [dict get $myDict "*"]
279 if {[dict exists $starDict -except]} {
280 set exceptions [dict get $starDict -except]
281 if {[lsearch $exceptions $optName] >= 0} {
282 set addOpt 0
283 }
284
285 }
286 if {[dict exists $myOptionDict $optName]} {
287 set addOpt 0
288 }
289 }
290 if {$addOpt} {
291 lappend cmd $optName $val
292 }
293
294 }
295
296 }
297 }
298 } else {
299 foreach optName [dict keys $myDict] {
300 set optInfos [dict get $myDict $optName]
301 set resource [dict get $optInfos -resource]
302 set class [namespace tail $className]
303 set class [string totitle $class]
304 set val ""
305 catch {
306 set val [::option get $win $resource $class]
307 }
308 if {$val ne ""} {
309 if {[dict exists $optInfos -as] } {
310 set optName [dict get $optInfos -as]
311 }
312 lappend cmd $optName $val
313 }
314 }
315 }
316 lappend cmd {*}$opts
317 uplevel 1 $cmd
318 }
319
320 } ; # end ::itcl::builtin
321
322 set ::itcl::internal::dicts::hullTypes [list \
323 frame \
324 toplevel \
325 labelframe \
326 ttk:frame \
327 ttk:toplevel \
328 ttk:labelframe \
329 ]
330
331 namespace eval ::itcl::builtin::Info {
332
333 proc hulltypes {args} {
334 namespace upvar ::itcl::internal::dicts hullTypes hullTypes
335
336 set numArgs [llength $args]
337 if {$numArgs > 1} {
338 error "wrong # args should be: info hulltypes ?<pattern>?"
339 }
340 set pattern ""
341 if {$numArgs > 0} {
342 set pattern [lindex $args 0]
343 }
344 if {$pattern ne ""} {
345 return [lsearch -all -inline -glob $hullTypes $pattern]
346 }
347 return $hullTypes
348
349 }
350
351 proc widgetclasses {args} {
352 set numArgs [llength $args]
353 if {$numArgs > 1} {
354 error "wrong # args should be: info widgetclasses ?<pattern>?"
355 }
356 set pattern ""
357 if {$numArgs > 0} {
358 set pattern [lindex $args 0]
359 }
360 set myDict [set ::itcl::internal::dicts::classes]
361 if {![dict exists $myDict widget]} {
362 return [list]
363 }
364 set myDict [dict get $myDict widget]
365 set result [list]
366 if {$pattern ne ""} {
367 foreach key [dict keys $myDict] {
368 set myInfo [dict get $myDict $key]
369 set value [dict get $myInfo -widget]
370 if {[string match $pattern $value]} {
371 lappend result $value
372 }
373 }
374 } else {
375 foreach key [dict keys $myDict] {
376 set myInfo [dict get $myDict $key]
377 lappend result [dict get $myInfo -widget]
378 }
379 }
380 return $result
381 }
382
383 proc widgets {args} {
384 set numArgs [llength $args]
385 if {$numArgs > 1} {
386 error "wrong # args should be: info widgets ?<pattern>?"
387 }
388 set pattern ""
389 if {$numArgs > 0} {
390 set pattern [lindex $args 0]
391 }
392 set myDict [set ::itcl::internal::dicts::classes]
393 if {![dict exists $myDict widget]} {
394 return [list]
395 }
396 set myDict [dict get $myDict widget]
397 set result [list]
398 if {$pattern ne ""} {
399 foreach key [dict keys $myDict] {
400 set myInfo [dict get $myDict $key]
401 set value [dict get $myInfo -name]
402 if {[string match $pattern $value]} {
403 lappend result $value
404 }
405 }
406 } else {
407 foreach key [dict keys $myDict] {
408 set myInfo [dict get $myDict $key]
409 lappend result [dict get $myInfo -name]
410 }
411 }
412 return $result
413 }
414
415 proc widgetadaptors {args} {
416 set numArgs [llength $args]
417 if {$numArgs > 1} {
418 error "wrong # args should be: info widgetadaptors ?<pattern>?"
419 }
420 set pattern ""
421 if {$numArgs > 0} {
422 set pattern [lindex $args 0]
423 }
424 set myDict [set ::itcl::internal::dicts::classes]
425 if {![dict exists $myDict widgetadaptor]} {
426 return [list]
427 }
428 set myDict [dict get $myDict widgetadaptor]
429 set result [list]
430 if {$pattern ne ""} {
431 foreach key [dict keys $myDict] {
432 set myInfo [dict get $myDict $key]
433 set value [dict get $myInfo -name]
434 if {[string match $pattern $value]} {
435 lappend result $value
436 }
437 }
438 } else {
439 foreach key [dict keys $myDict] {
440 set myInfo [dict get $myDict $key]
441 lappend result [dict get $myInfo -name]
442 }
443 }
444 return $result
445 }
446
447 } ; # end ::itcl::builtin::Info