Mercurial > repos > rliterman > csp2

comparison CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/itcl4.2.3/itclHullCmds.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 # itclHullCmds.tcl
3 # ----------------------------------------------------------------------
4 # Invoked automatically upon startup to customize the interpreter
5 # for [incr Tcl] when one of setupcomponent or createhull 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
17 namespace eval ::itcl::internal::commands {
18
19 # ======================= widgetDeleted ===========================
20
21 proc widgetDeleted {oldName newName op} {
22 # The widget is beeing deleted, so we have to delete the object
23 # which had the widget as itcl_hull too!
24 # We have to get the real name from for example
25 # ::itcl::internal::widgets::hull1.lw
26 # we need only .lw here
27
28 #puts stderr "widgetDeleted!$oldName!$newName!$op!"
29 set cmdName [namespace tail $oldName]
30 set flds [split $cmdName {.}]
31 set cmdName .[join [lrange $flds 1 end] {.}]
32 #puts stderr "DELWIDGET![namespace current]!$cmdName![::info command $cmdName]!"
33 rename $cmdName {}
34 }
35
36 }
37
38 namespace eval ::itcl::builtin {
39
40 # ======================= createhull ===========================
41 # the hull widget is a tk widget which is the (mega) widget handled behind the itcl
42 # extendedclass/itcl widget.
43 # It is created be renaming the itcl class object to a temporary name <itcl object name>_
44 # creating the widget with the
45 # appropriate options and the installing that as the "hull" widget (the container)
46 # All the options in args and the options delegated to component itcl_hull are used
47 # Then a unique name (hull_widget_name) in the itcl namespace is created for widget:
48 # ::itcl::internal::widgets::hull<unique number><namespace tail path>
49 # and widget is renamed to that name
50 # Finally the <itcl object name>_ is renamed to the original <itcl object name> again
51 # Component itcl_hull is created if not existent
52 # itcl_hull is set to the hull_widget_name and the <itcl object name>
53 # is returned to the caller
54 # ==============================================================
55
56 proc createhull {widget_type path args} {
57 variable hullCount
58 upvar this this
59 upvar win win
60
61
62 #puts stderr "il-1![::info level -1]!$this!"
63 #puts stderr "createhull!$widget_type!$path!$args!$this![::info command $this]!"
64 #puts stderr "ns1![uplevel 1 namespace current]!"
65 #puts stderr "ns2![uplevel 2 namespace current]!"
66 #puts stderr "ns3![uplevel 3 namespace current]!"
67 #puts stderr "level-1![::info level -1]!"
68 #puts stderr "level-2![::info level -2]!"
69 # set my_this [namespace tail $this]
70 set my_this $this
71 set tmp $my_this
72 #puts stderr "II![::info command $this]![::info command $tmp]!"
73 #puts stderr "rename1!rename $my_this ${tmp}_!"
74 rename ::$my_this ${tmp}_
75 set options [list]
76 foreach {option_name value} $args {
77 switch -glob -- $option_name {
78 -class {
79 lappend options $option_name [namespace tail $value]
80 }
81 -* {
82 lappend options $option_name $value
83 }
84 default {
85 return -code error "bad option name\"$option_name\" options must start with a \"-\""
86 }
87 }
88 }
89 set my_win [namespace tail $path]
90 set cmd [list $widget_type $my_win]
91 #puts stderr "my_win!$my_win!cmd!$cmd!$path!"
92 if {[llength $options] > 0} {
93 lappend cmd {*}$options
94 }
95 set widget [uplevel 1 $cmd]
96 #puts stderr "widget!$widget!"
97 trace add command $widget delete ::itcl::internal::commands::widgetDeleted
98 set opts [uplevel 1 info delegated options]
99 foreach entry $opts {
100 foreach {optName compName} $entry break
101 if {$compName eq "itcl_hull"} {
102 set optInfos [uplevel 1 info delegated option $optName]
103 set realOptName [lindex $optInfos 4]
104 # strip off the "-" at the beginning
105 set myOptName [string range $realOptName 1 end]
106 set my_opt_val [option get $my_win $myOptName *]
107 if {$my_opt_val ne ""} {
108 $my_win configure -$myOptName $my_opt_val
109 }
110 }
111 }
112 set idx 1
113 while {1} {
114 set widgetName ::itcl::internal::widgets::hull${idx}$my_win
115 #puts stderr "widgetName!$widgetName!"
116 if {[string length [::info command $widgetName]] == 0} {
117 break
118 }
119 incr idx
120 }
121 #puts stderr "rename2!rename $widget $widgetName!"
122 set dorename 0
123 rename $widget $widgetName
124 #puts stderr "rename3!rename ${tmp}_ $tmp![::info command ${tmp}_]!my_this!$my_this!"
125 rename ${tmp}_ ::$tmp
126 set exists [uplevel 1 ::info exists itcl_hull]
127 if {!$exists} {
128 # that does not yet work, beacause of problems with resolving
129 ::itcl::addcomponent $my_this itcl_hull
130 }
131 upvar itcl_hull itcl_hull
132 ::itcl::setcomponent $my_this itcl_hull $widgetName
133 #puts stderr "IC![::info command $my_win]!"
134 set exists [uplevel 1 ::info exists itcl_interior]
135 if {!$exists} {
136 # that does not yet work, beacause of problems with resolving
137 ::itcl::addcomponent $this itcl_interior
138 }
139 upvar itcl_interior itcl_interior
140 set itcl_interior $my_win
141 #puts stderr "hull end!win!$win!itcl_hull!$itcl_hull!itcl_interior!$itcl_interior!"
142 return $my_win
143 }
144
145 # ======================= addToItclOptions ===========================
146
147 proc addToItclOptions {my_class my_win myOptions argsDict} {
148 upvar win win
149 upvar itcl_hull itcl_hull
150
151 set opt_lst [list configure]
152 foreach opt [lsort $myOptions] {
153 #puts stderr "IOPT!$opt!$my_class!$my_win![::itcl::is class $my_class]!"
154 set isClass [::itcl::is class $my_class]
155 set found 0
156 if {$isClass} {
157 if {[catch {
158 set resource [namespace eval $my_class info option $opt -resource]
159 set class [namespace eval $my_class info option $opt -class]
160 set default_val [uplevel 2 info option $opt -default]
161 set found 1
162 } msg]} {
163 # puts stderr "MSG!$opt!$my_class!$msg!"
164 }
165 } else {
166 set tmp_win [uplevel #0 $my_class .___xx]
167
168 set my_info [$tmp_win configure $opt]
169 set resource [lindex $my_info 1]
170 set class [lindex $my_info 2]
171 set default_val [lindex $my_info 3]
172 uplevel #0 destroy $tmp_win
173 set found 1
174 }
175 if {$found} {
176 if {[catch {
177 set val [uplevel #0 ::option get $win $resource $class]
178 } msg]} {
179 set val ""
180 }
181 if {[::dict exists $argsDict $opt]} {
182 # we have an explicitly set option
183 set val [::dict get $argsDict $opt]
184 } else {
185 if {[string length $val] == 0} {
186 set val $default_val
187 }
188 }
189 set ::itcl::internal::variables::${my_win}::itcl_options($opt) $val
190 set ::itcl::internal::variables::${my_win}::__itcl_option_infos($opt) [list $resource $class $default_val]
191 #puts stderr "OPT1!$opt!$val!"
192 # uplevel 1 [list set itcl_options($opt) [list $val]]
193 if {[catch {uplevel 1 $win configure $opt [list $val]} msg]} {
194 #puts stderr "addToItclOptions ERR!$msg!$my_class!$win!configure!$opt!$val!"
195 }
196 }
197 }
198 }
199
200 # ======================= setupcomponent ===========================
201
202 proc setupcomponent {comp using widget_type path args} {
203 upvar this this
204 upvar win win
205 upvar itcl_hull itcl_hull
206
207 #puts stderr "setupcomponent!$comp!$widget_type!$path!$args!$this!$win!$itcl_hull!"
208 #puts stderr "CONT![uplevel 1 info context]!"
209 #puts stderr "ns1![uplevel 1 namespace current]!"
210 #puts stderr "ns2![uplevel 2 namespace current]!"
211 #puts stderr "ns3![uplevel 3 namespace current]!"
212 set my_comp_object [lindex [uplevel 1 info context] 1]
213 if {[::info exists ::itcl::internal::component_objects($my_comp_object)]} {
214 set my_comp_object [set ::itcl::internal::component_objects($my_comp_object)]
215 } else {
216 set ::itcl::internal::component_objects($path) $my_comp_object
217 }
218 set options [list]
219 foreach {option_name value} $args {
220 switch -glob -- $option_name {
221 -* {
222 lappend options $option_name $value
223 }
224 default {
225 return -code error "bad option name\"$option_name\" options must start with a \"-\""
226 }
227 }
228 }
229 if {[llength $args]} {
230 set argsDict [dict create {*}$args]
231 } else {
232 set argsDict [dict create]
233 }
234 set cmd [list $widget_type $path]
235 if {[llength $options] > 0} {
236 lappend cmd {*}$options
237 }
238 #puts stderr "cmd0![::info command $widget_type]!$path![::info command $path]!"
239 #puts stderr "cmd1!$cmd!"
240 # set my_comp [uplevel 3 $cmd]
241 set my_comp [uplevel #0 $cmd]
242 #puts stderr 111![::info command $path]!
243 ::itcl::setcomponent $this $comp $my_comp
244 set opts [uplevel 1 info delegated options]
245 foreach entry $opts {
246 foreach {optName compName} $entry break
247 if {$compName eq $my_comp} {
248 set optInfos [uplevel 1 info delegated option $optName]
249 set realOptName [lindex $optInfos 4]
250 # strip off the "-" at the beginning
251 set myOptName [string range $realOptName 1 end]
252 set my_opt_val [option get $my_win $myOptName *]
253 if {$my_opt_val ne ""} {
254 $my_comp configure -$myOptName $my_opt_val
255 }
256 }
257 }
258 set my_class $widget_type
259 set my_parent_class [uplevel 1 namespace current]
260 if {[catch {
261 set myOptions [namespace eval $my_class {info classoptions}]
262 } msg]} {
263 set myOptions [list]
264 }
265 foreach entry [$path configure] {
266 foreach {opt dummy1 dummy2 dummy3} $entry break
267 lappend myOptions $opt
268 }
269 #puts stderr "OPTS!$myOptions!"
270 addToItclOptions $widget_type $my_comp_object $myOptions $argsDict
271 #puts stderr END!$path![::info command $path]!
272 }
273
274 proc itcl_initoptions {args} {
275 puts stderr "ITCL_INITOPT!$args!"
276 }
277
278 # ======================= initoptions ===========================
279
280 proc initoptions {args} {
281 upvar win win
282 upvar itcl_hull itcl_hull
283 upvar itcl_option_components itcl_option_components
284
285 #puts stderr "INITOPT!!$win!"
286 if {[llength $args]} {
287 set argsDict [dict create {*}$args]
288 } else {
289 set argsDict [dict create]
290 }
291 set my_class [uplevel 1 namespace current]
292 set myOptions [namespace eval $my_class {info classoptions}]
293 if {[dict exists $::itcl::internal::dicts::classComponents $my_class]} {
294 set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
295 # set myOptions [lsort -unique [namespace eval $my_class {info options}]]
296 foreach comp [uplevel 1 info components] {
297 if {[dict exists $class_info_dict $comp -keptoptions]} {
298 foreach my_opt [dict get $class_info_dict $comp -keptoptions] {
299 if {[lsearch $myOptions $my_opt] < 0} {
300 #puts stderr "KEOPT!$my_opt!"
301 lappend myOptions $my_opt
302 }
303 }
304 }
305 }
306 } else {
307 set class_info_dict [list]
308 }
309 #puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
310 set opt_lst [list configure]
311 set my_win $win
312 foreach opt [lsort $myOptions] {
313 set found 0
314 if {[catch {
315 set resource [uplevel 1 info option $opt -resource]
316 set class [uplevel 1 info option $opt -class]
317 set default_val [uplevel 1 info option $opt -default]
318 set found 1
319 } msg]} {
320 # puts stderr "MSG!$opt!$msg!"
321 }
322 #puts stderr "OPT!$opt!$found!"
323 if {$found} {
324 if {[catch {
325 set val [uplevel #0 ::option get $my_win $resource $class]
326 } msg]} {
327 set val ""
328 }
329 if {[::dict exists $argsDict $opt]} {
330 # we have an explicitly set option
331 set val [::dict get $argsDict $opt]
332 } else {
333 if {[string length $val] == 0} {
334 set val $default_val
335 }
336 }
337 set ::itcl::internal::variables::${win}::itcl_options($opt) $val
338 set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
339 #puts stderr "OPT1!$opt!$val!"
340 # uplevel 1 [list set itcl_options($opt) [list $val]]
341 if {[catch {uplevel 1 $my_win configure $opt [list $val]} msg]} {
342 puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
343 }
344 }
345 foreach comp [dict keys $class_info_dict] {
346 #puts stderr "OPT1!$opt!$comp![dict get $class_info_dict $comp]!"
347 if {[dict exists $class_info_dict $comp -keptoptions]} {
348 if {[lsearch [dict get $class_info_dict $comp -keptoptions] $opt] >= 0} {
349 if {$found == 0} {
350 # we use the option value of the first component for setting
351 # the option, as the components are traversed in the dict
352 # depending on the ordering of the component creation!!
353 set my_info [uplevel 1 \[set $comp\] configure $opt]
354 set resource [lindex $my_info 1]
355 set class [lindex $my_info 2]
356 set default_val [lindex $my_info 3]
357 set found 2
358 set val [uplevel #0 ::option get $my_win $resource $class]
359 if {[::dict exists $argsDict $opt]} {
360 # we have an explicitly set option
361 set val [::dict get $argsDict $opt]
362 } else {
363 if {[string length $val] == 0} {
364 set val $default_val
365 }
366 }
367 #puts stderr "OPT2!$opt!$val!"
368 set ::itcl::internal::variables::${win}::itcl_options($opt) $val
369 set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
370 # uplevel 1 [list set itcl_options($opt) [list $val]]
371 }
372 if {[catch {uplevel 1 \[set $comp\] configure $opt [list $val]} msg]} {
373 puts stderr "initoptions ERR2!$msg!$my_class!$comp!configure!$opt!$val!"
374 }
375 if {![uplevel 1 info exists itcl_option_components($opt)]} {
376 set itcl_option_components($opt) [list]
377 }
378 if {[lsearch [set itcl_option_components($opt)] $comp] < 0} {
379 if {![catch {
380 set optval [uplevel 1 [list set itcl_options($opt)]]
381 } msg3]} {
382 uplevel 1 \[set $comp\] configure $opt $optval
383 }
384 lappend itcl_option_components($opt) $comp
385 }
386 }
387 }
388 }
389 }
390 # uplevel 1 $opt_lst
391 }
392
393 # ======================= setoptions ===========================
394
395 proc setoptions {args} {
396
397 #puts stderr "setOPT!!$args!"
398 if {[llength $args]} {
399 set argsDict [dict create {*}$args]
400 } else {
401 set argsDict [dict create]
402 }
403 set my_class [uplevel 1 namespace current]
404 set myOptions [namespace eval $my_class {info options}]
405 #puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
406 set opt_lst [list configure]
407 foreach opt [lsort $myOptions] {
408 set found 0
409 if {[catch {
410 set resource [uplevel 1 info option $opt -resource]
411 set class [uplevel 1 info option $opt -class]
412 set default_val [uplevel 1 info option $opt -default]
413 set found 1
414 } msg]} {
415 # puts stderr "MSG!$opt!$msg!"
416 }
417 #puts stderr "OPT!$opt!$found!"
418 if {$found} {
419 set val ""
420 if {[::dict exists $argsDict $opt]} {
421 # we have an explicitly set option
422 set val [::dict get $argsDict $opt]
423 } else {
424 if {[string length $val] == 0} {
425 set val $default_val
426 }
427 }
428 set myObj [uplevel 1 set this]
429 #puts stderr "myObj!$myObj!"
430 set ::itcl::internal::variables::${myObj}::itcl_options($opt) $val
431 set ::itcl::internal::variables::${myObj}::__itcl_option_infos($opt) [list $resource $class $default_val]
432 #puts stderr "OPT1!$opt!$val!"
433 uplevel 1 [list set itcl_options($opt) [list $val]]
434 # if {[catch {uplevel 1 $myObj configure $opt [list $val]} msg]} {
435 #puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
436 # }
437 }
438 }
439 # uplevel 1 $opt_lst
440 }
441
442 # ========================= keepcomponentoption ======================
443 # Invoked by Tcl during evaluating constructor whenever
444 # the "keepcomponentoption" command is invoked to list the options
445 # to be kept when an ::itcl::extendedclass component has been setup
446 # for an object.
447 #
448 # It checks, for all arguments, if the opt is an option of that class
449 # and of that component. If that is the case it adds the component name
450 # to the list of components for that option.
451 # The variable is the object variable: itcl_option_components($opt)
452 #
453 # Handles the following syntax:
454 #
455 # keepcomponentoption <componentName> <optionName> ?<optionName> ...?
456 #
457 # ======================================================================
458
459
460 proc keepcomponentoption {args} {
461 upvar win win
462 upvar itcl_hull itcl_hull
463
464 set usage "wrong # args, should be: keepcomponentoption componentName optionName ?optionName ...?"
465
466 #puts stderr "KEEP!$args![uplevel 1 namespace current]!"
467 if {[llength $args] < 2} {
468 puts stderr $usage
469 return -code error
470 }
471 set my_hull [uplevel 1 set itcl_hull]
472 set my_class [uplevel 1 namespace current]
473 set comp [lindex $args 0]
474 set args [lrange $args 1 end]
475 set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
476 if {![dict exists $class_info_dict $comp]} {
477 puts stderr "keepcomponentoption cannot find component \"$comp\""
478 return -code error
479 }
480 set class_comp_dict [dict get $class_info_dict $comp]
481 if {![dict exists $class_comp_dict -keptoptions]} {
482 dict set class_comp_dict -keptoptions [list]
483 }
484 foreach opt $args {
485 #puts stderr "KEEP!$opt!"
486 if {[string range $opt 0 0] ne "-"} {
487 puts stderr "keepcomponentoption: option must begin with a \"-\"!"
488 return -code error
489 }
490 if {[lsearch [dict get $class_comp_dict -keptoptions] $opt] < 0} {
491 dict lappend class_comp_dict -keptoptions $opt
492 }
493 }
494 if {![info exists ::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])]} {
495 set comp_object $::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])
496 } else {
497 set comp_object "unknown_comp_obj_$comp!"
498 }
499 dict set class_info_dict $comp $class_comp_dict
500 dict set ::itcl::internal::dicts::classComponents $my_class $class_info_dict
501 puts stderr "CLDI!$class_comp_dict!"
502 addToItclOptions $my_class $comp_object $args [list]
503 }
504
505 proc ignorecomponentoption {args} {
506 puts stderr "IGNORE_COMPONENT_OPTION!$args!"
507 }
508
509 proc renamecomponentoption {args} {
510 puts stderr "rename_COMPONENT_OPTION!$args!"
511 }
512
513 proc addoptioncomponent {args} {
514 puts stderr "ADD_OPTION_COMPONENT!$args!"
515 }
516
517 proc ignoreoptioncomponent {args} {
518 puts stderr "IGNORE_OPTION_COMPONENT!$args!"
519 }
520
521 proc renameoptioncomponent {args} {
522 puts stderr "RENAME_OPTION_COMPONENT!$args!"
523 }
524
525 proc getEclassOptions {args} {
526 upvar win win
527
528 #puts stderr "getEclassOptions!$args!$win![uplevel 1 namespace current]!"
529 #parray ::itcl::internal::variables::${win}::itcl_options
530 set result [list]
531 foreach opt [array names ::itcl::internal::variables::${win}::itcl_options] {
532 if {[catch {
533 foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
534 lappend result [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
535 } msg]} {
536 }
537 }
538 return $result
539 }
540
541 proc eclassConfigure {args} {
542 upvar win win
543
544 #puts stderr "+++ eclassConfigure!$args!"
545 if {[llength $args] > 1} {
546 foreach {opt val} $args break
547 if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
548 set ::itcl::internal::variables::${win}::itcl_options($opt) $val
549 return
550 }
551 } else {
552 foreach {opt} $args break
553 if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
554 #puts stderr "OP![set ::itcl::internal::variables::${win}::itcl_options($opt)]!"
555 foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
556 return [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
557 }
558 }
559 return -code error
560 }
561
562 }