Mercurial > repos > rliterman > csp2

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