Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/itcl4.2.3/itclWidget.tcl @ 68:5028fdace37b

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