Mercurial > repos > rliterman > csp2

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