1# ---------------------------------------------------------------------------- 2# widget.tcl 3# This file is part of Unifix BWidget Toolkit 4# $Id: widget.tcl,v 1.37 2009/11/01 20:20:16 oberdorfer Exp $ 5# ---------------------------------------------------------------------------- 6# Index of commands: 7# - Widget::tkinclude 8# - Widget::bwinclude 9# - Widget::declare 10# - Widget::addmap 11# - Widget::init 12# - Widget::destroy 13# - Widget::setoption 14# - Widget::configure 15# - Widget::cget 16# - Widget::subcget 17# - Widget::hasChanged 18# - Widget::options 19# - Widget::getArgument 20# - Widget::getallwidgets 21# - Widget::_get_tkwidget_options 22# - Widget::_test_tkresource 23# - Widget::_test_bwresource 24# - Widget::_test_synonym 25# - Widget::_test_string 26# - Widget::_test_flag 27# - Widget::_test_enum 28# - Widget::_test_int 29# - Widget::_test_boolean 30# ---------------------------------------------------------------------------- 31# Each megawidget gets a namespace of the same name inside the Widget namespace 32# Each of these has an array opt, which contains information about the 33# megawidget options. It maps megawidget options to a list with this format: 34# {optionType defaultValue isReadonly {additionalOptionalInfo}} 35# Option types and their additional optional info are: 36# TkResource {genericTkWidget genericTkWidgetOptionName} 37# BwResource {nothing} 38# Enum {list of enumeration values} 39# Int {Boundary information} 40# Boolean {nothing} 41# String {nothing} 42# Flag {string of valid flag characters} 43# Synonym {nothing} 44# Color {nothing} 45# 46# Next, each namespace has an array map, which maps class options to their 47# component widget options: 48# map(-foreground) => {.e -foreground .f -foreground} 49# 50# Each has an array ${path}:opt, which contains the value of each megawidget 51# option for a particular instance $path of the megawidget, and an array 52# ${path}:mod, which stores the "changed" status of configuration options. 53 54# Steps for creating a bwidget megawidget: 55# 1. parse args to extract subwidget spec 56# 2. Create frame with appropriate class and command line options 57# 3. Get initialization options from optionDB, using frame 58# 4. create subwidgets 59 60# Uses newer string operations 61package require Tcl 8.1.1 62 63namespace eval Widget { 64 variable _optiontype 65 variable _class 66 variable _tk_widget 67 68 # This controls whether we try to use themed widgets from Tile 69 variable _theme 0 70 71 variable _aqua [expr {($::tcl_version >= 8.4) && 72 [string equal [tk windowingsystem] "aqua"]}] 73 74 array set _optiontype { 75 TkResource Widget::_test_tkresource 76 BwResource Widget::_test_bwresource 77 Enum Widget::_test_enum 78 Int Widget::_test_int 79 Boolean Widget::_test_boolean 80 String Widget::_test_string 81 Flag Widget::_test_flag 82 Synonym Widget::_test_synonym 83 Color Widget::_test_color 84 Padding Widget::_test_padding 85 } 86 87 proc use {} {} 88} 89 90 91# ---------------------------------------------------------------------------- 92# Command Widget::tkinclude 93# Includes tk widget resources to BWidget widget. 94# class class name of the BWidget 95# tkwidget tk widget to include 96# subpath subpath to configure 97# args additionnal args for included options 98# ---------------------------------------------------------------------------- 99proc Widget::tkinclude { class tkwidget subpath args } { 100 foreach {cmd lopt} $args { 101 # cmd can be 102 # include options to include lopt = {opt ...} 103 # remove options to remove lopt = {opt ...} 104 # rename options to rename lopt = {opt newopt ...} 105 # prefix options to prefix lopt = {pref opt opt ..} 106 # initialize set default value for options lopt = {opt value ...} 107 # readonly set readonly flag for options lopt = {opt flag ...} 108 switch -- $cmd { 109 remove { 110 foreach option $lopt { 111 set remove($option) 1 112 } 113 } 114 include { 115 foreach option $lopt { 116 set include($option) 1 117 } 118 } 119 prefix { 120 set prefix [lindex $lopt 0] 121 foreach option [lrange $lopt 1 end] { 122 set rename($option) "-$prefix[string range $option 1 end]" 123 } 124 } 125 rename - 126 readonly - 127 initialize { 128 array set $cmd $lopt 129 } 130 default { 131 return -code error "invalid argument \"$cmd\"" 132 } 133 } 134 } 135 136 namespace eval $class {} 137 upvar 0 ${class}::opt classopt 138 upvar 0 ${class}::map classmap 139 upvar 0 ${class}::map$subpath submap 140 upvar 0 ${class}::optionExports exports 141 142 set foo [$tkwidget ".ericFoo###"] 143 # create resources informations from tk widget resources 144 foreach optdesc [_get_tkwidget_options $tkwidget] { 145 set option [lindex $optdesc 0] 146 if { (![info exists include] || [info exists include($option)]) && 147 ![info exists remove($option)] } { 148 if { [llength $optdesc] == 3 } { 149 # option is a synonym 150 set syn [lindex $optdesc 1] 151 if { ![info exists remove($syn)] } { 152 # original option is not removed 153 if { [info exists rename($syn)] } { 154 set classopt($option) [list Synonym $rename($syn)] 155 } else { 156 set classopt($option) [list Synonym $syn] 157 } 158 } 159 } else { 160 if { [info exists rename($option)] } { 161 set realopt $option 162 set option $rename($option) 163 } else { 164 set realopt $option 165 } 166 if { [info exists initialize($option)] } { 167 set value $initialize($option) 168 } else { 169 set value [lindex $optdesc 1] 170 } 171 if { [info exists readonly($option)] } { 172 set ro $readonly($option) 173 } else { 174 set ro 0 175 } 176 set classopt($option) \ 177 [list TkResource $value $ro [list $tkwidget $realopt]] 178 179 # Add an option database entry for this option 180 set optionDbName ".[lindex [_configure_option $realopt ""] 0]" 181 if { ![string equal $subpath ":cmd"] } { 182 set optionDbName "$subpath$optionDbName" 183 } 184 option add *${class}$optionDbName $value widgetDefault 185 lappend exports($option) "$optionDbName" 186 187 # Store the forward and backward mappings for this 188 # option <-> realoption pair 189 lappend classmap($option) $subpath "" $realopt 190 set submap($realopt) $option 191 } 192 } 193 } 194 ::destroy $foo 195} 196 197 198# ---------------------------------------------------------------------------- 199# Command Widget::bwinclude 200# Includes BWidget resources to BWidget widget. 201# class class name of the BWidget 202# subclass BWidget class to include 203# subpath subpath to configure 204# args additionnal args for included options 205# ---------------------------------------------------------------------------- 206proc Widget::bwinclude { class subclass subpath args } { 207 foreach {cmd lopt} $args { 208 # cmd can be 209 # include options to include lopt = {opt ...} 210 # remove options to remove lopt = {opt ...} 211 # rename options to rename lopt = {opt newopt ...} 212 # prefix options to prefix lopt = {prefix opt opt ...} 213 # initialize set default value for options lopt = {opt value ...} 214 # readonly set readonly flag for options lopt = {opt flag ...} 215 switch -- $cmd { 216 remove { 217 foreach option $lopt { 218 set remove($option) 1 219 } 220 } 221 include { 222 foreach option $lopt { 223 set include($option) 1 224 } 225 } 226 prefix { 227 set prefix [lindex $lopt 0] 228 foreach option [lrange $lopt 1 end] { 229 set rename($option) "-$prefix[string range $option 1 end]" 230 } 231 } 232 rename - 233 readonly - 234 initialize { 235 array set $cmd $lopt 236 } 237 default { 238 return -code error "invalid argument \"$cmd\"" 239 } 240 } 241 } 242 243 namespace eval $class {} 244 upvar 0 ${class}::opt classopt 245 upvar 0 ${class}::map classmap 246 upvar 0 ${class}::map$subpath submap 247 upvar 0 ${class}::optionExports exports 248 upvar 0 ${subclass}::opt subclassopt 249 upvar 0 ${subclass}::optionExports subexports 250 251 # create resources informations from BWidget resources 252 foreach {option optdesc} [array get subclassopt] { 253 set subOption $option 254 if { (![info exists include] || [info exists include($option)]) && 255 ![info exists remove($option)] } { 256 set type [lindex $optdesc 0] 257 if { [string equal $type "Synonym"] } { 258 # option is a synonym 259 set syn [lindex $optdesc 1] 260 if { ![info exists remove($syn)] } { 261 if { [info exists rename($syn)] } { 262 set classopt($option) [list Synonym $rename($syn)] 263 } else { 264 set classopt($option) [list Synonym $syn] 265 } 266 } 267 } else { 268 if { [info exists rename($option)] } { 269 set realopt $option 270 set option $rename($option) 271 } else { 272 set realopt $option 273 } 274 if { [info exists initialize($option)] } { 275 set value $initialize($option) 276 } else { 277 set value [lindex $optdesc 1] 278 } 279 if { [info exists readonly($option)] } { 280 set ro $readonly($option) 281 } else { 282 set ro [lindex $optdesc 2] 283 } 284 set classopt($option) \ 285 [list $type $value $ro [lindex $optdesc 3]] 286 287 # Add an option database entry for this option 288 foreach optionDbName $subexports($subOption) { 289 if { ![string equal $subpath ":cmd"] } { 290 set optionDbName "$subpath$optionDbName" 291 } 292 # Only add the option db entry if we are overriding the 293 # normal widget default 294 if { [info exists initialize($option)] } { 295 option add *${class}$optionDbName $value \ 296 widgetDefault 297 } 298 lappend exports($option) "$optionDbName" 299 } 300 301 # Store the forward and backward mappings for this 302 # option <-> realoption pair 303 lappend classmap($option) $subpath $subclass $realopt 304 set submap($realopt) $option 305 } 306 } 307 } 308} 309 310 311# ---------------------------------------------------------------------------- 312# Command Widget::declare 313# Declares new options to BWidget class. 314# ---------------------------------------------------------------------------- 315proc Widget::declare { class optlist } { 316 variable _optiontype 317 318 namespace eval $class {} 319 upvar 0 ${class}::opt classopt 320 upvar 0 ${class}::optionExports exports 321 upvar 0 ${class}::optionClass optionClass 322 323 foreach optdesc $optlist { 324 set option [lindex $optdesc 0] 325 set optdesc [lrange $optdesc 1 end] 326 set type [lindex $optdesc 0] 327 328 if { ![info exists _optiontype($type)] } { 329 # invalid resource type 330 return -code error "invalid option type \"$type\"" 331 } 332 333 if { [string equal $type "Synonym"] } { 334 # test existence of synonym option 335 set syn [lindex $optdesc 1] 336 if { ![info exists classopt($syn)] } { 337 return -code error "unknow option \"$syn\" for Synonym \"$option\"" 338 } 339 set classopt($option) [list Synonym $syn] 340 continue 341 } 342 343 # all other resource may have default value, readonly flag and 344 # optional arg depending on type 345 set value [lindex $optdesc 1] 346 set ro [lindex $optdesc 2] 347 set arg [lindex $optdesc 3] 348 349 if { [string equal $type "BwResource"] } { 350 # We don't keep BwResource. We simplify to type of sub BWidget 351 set subclass [lindex $arg 0] 352 set realopt [lindex $arg 1] 353 if { ![string length $realopt] } { 354 set realopt $option 355 } 356 357 upvar 0 ${subclass}::opt subclassopt 358 if { ![info exists subclassopt($realopt)] } { 359 return -code error "unknow option \"$realopt\"" 360 } 361 set suboptdesc $subclassopt($realopt) 362 if { $value == "" } { 363 # We initialize default value 364 set value [lindex $suboptdesc 1] 365 } 366 set type [lindex $suboptdesc 0] 367 set ro [lindex $suboptdesc 2] 368 set arg [lindex $suboptdesc 3] 369 set optionDbName ".[lindex [_configure_option $option ""] 0]" 370 option add *${class}${optionDbName} $value widgetDefault 371 set exports($option) $optionDbName 372 set classopt($option) [list $type $value $ro $arg] 373 continue 374 } 375 376 # retreive default value for TkResource 377 if { [string equal $type "TkResource"] } { 378 set tkwidget [lindex $arg 0] 379 set foo [$tkwidget ".ericFoo##"] 380 set realopt [lindex $arg 1] 381 if { ![string length $realopt] } { 382 set realopt $option 383 } 384 set tkoptions [_get_tkwidget_options $tkwidget] 385 if { ![string length $value] } { 386 # We initialize default value 387 set ind [lsearch $tkoptions [list $realopt *]] 388 set value [lindex [lindex $tkoptions $ind] end] 389 } 390 set optionDbName ".[lindex [_configure_option $option ""] 0]" 391 option add *${class}${optionDbName} $value widgetDefault 392 set exports($option) $optionDbName 393 set classopt($option) [list TkResource $value $ro \ 394 [list $tkwidget $realopt]] 395 set optionClass($option) [lindex [$foo configure $realopt] 1] 396 ::destroy $foo 397 continue 398 } 399 400 if {[string equal $type "Color"]} { 401 if {[info exists ::BWidget::colors($value)]} { 402 set value $::BWidget::colors($value) 403 } 404 } 405 406 set optionDbName ".[lindex [_configure_option $option ""] 0]" 407 option add *${class}${optionDbName} $value widgetDefault 408 set exports($option) $optionDbName 409 # for any other resource type, we keep original optdesc 410 set classopt($option) [list $type $value $ro $arg] 411 } 412} 413 414 415proc Widget::define { class filename args } { 416 variable ::BWidget::use 417 set use($class) $args 418 set use($class,file) $filename 419 lappend use(classes) $class 420 421 if {[set x [lsearch -exact $args "-classonly"]] > -1} { 422 set args [lreplace $args $x $x] 423 } else { 424 interp alias {} ::${class} {} ${class}::create 425 proc ::${class}::use {} {} 426 427 bind $class <Destroy> [list Widget::destroy %W] 428 } 429 430 foreach class $args { ${class}::use } 431} 432 433 434proc Widget::create { class path {rename 1} } { 435 if {$rename} { rename $path ::$path:cmd } 436 proc ::$path { cmd args } \ 437 [subst {return \[eval \[linsert \$args 0 ${class}::\$cmd [list $path]\]\]}] 438 return $path 439} 440 441 442# ---------------------------------------------------------------------------- 443# Command Widget::addmap 444# ---------------------------------------------------------------------------- 445proc Widget::addmap { class subclass subpath options } { 446 upvar 0 ${class}::opt classopt 447 upvar 0 ${class}::optionExports exports 448 upvar 0 ${class}::optionClass optionClass 449 upvar 0 ${class}::map classmap 450 upvar 0 ${class}::map$subpath submap 451 452 foreach {option realopt} $options { 453 if { ![string length $realopt] } { 454 set realopt $option 455 } 456 set val [lindex $classopt($option) 1] 457 set optDb ".[lindex [_configure_option $realopt ""] 0]" 458 if { ![string equal $subpath ":cmd"] } { 459 set optDb "$subpath$optDb" 460 } 461 option add *${class}${optDb} $val widgetDefault 462 lappend exports($option) $optDb 463 # Store the forward and backward mappings for this 464 # option <-> realoption pair 465 lappend classmap($option) $subpath $subclass $realopt 466 set submap($realopt) $option 467 } 468} 469 470 471# ---------------------------------------------------------------------------- 472# Command Widget::syncoptions 473# ---------------------------------------------------------------------------- 474proc Widget::syncoptions { class subclass subpath options } { 475 upvar 0 ${class}::sync classync 476 477 foreach {option realopt} $options { 478 if { ![string length $realopt] } { 479 set realopt $option 480 } 481 set classync($option) [list $subpath $subclass $realopt] 482 } 483} 484 485 486# ---------------------------------------------------------------------------- 487# Command Widget::init 488# ---------------------------------------------------------------------------- 489proc Widget::init { class path options } { 490 variable _inuse 491 variable _class 492 variable _optiontype 493 494 upvar 0 ${class}::opt classopt 495 upvar 0 ${class}::$path:opt pathopt 496 upvar 0 ${class}::$path:mod pathmod 497 upvar 0 ${class}::map classmap 498 upvar 0 ${class}::$path:init pathinit 499 500 if { [info exists pathopt] } { 501 unset pathopt 502 } 503 if { [info exists pathmod] } { 504 unset pathmod 505 } 506 # We prefer to use the actual widget for option db queries, but if it 507 # doesn't exist yet, do the next best thing: create a widget of the 508 # same class and use that. 509 set fpath $path 510 set rdbclass [string map [list :: ""] $class] 511 if { ![winfo exists $path] } { 512 set fpath ".#BWidget.#Class#$class" 513 # encapsulation frame to not pollute '.' childspace 514 if {![winfo exists ".#BWidget"]} { frame ".#BWidget" } 515 if { ![winfo exists $fpath] } { 516 frame $fpath -class $rdbclass 517 } 518 } 519 foreach {option optdesc} [array get classopt] { 520 set pathmod($option) 0 521 if { [info exists classmap($option)] } { 522 continue 523 } 524 set type [lindex $optdesc 0] 525 if { [string equal $type "Synonym"] } { 526 continue 527 } 528 if { [string equal $type "TkResource"] } { 529 set alt [lindex [lindex $optdesc 3] 1] 530 } else { 531 set alt "" 532 } 533 set optdb [lindex [_configure_option $option $alt] 0] 534 set def [option get $fpath $optdb $rdbclass] 535 if { [string length $def] } { 536 set pathopt($option) $def 537 } else { 538 set pathopt($option) [lindex $optdesc 1] 539 } 540 } 541 542 if {![info exists _inuse($class)]} { set _inuse($class) 0 } 543 incr _inuse($class) 544 545 set _class($path) $class 546 foreach {option value} $options { 547 if { ![info exists classopt($option)] } { 548 unset pathopt 549 unset pathmod 550 return -code error "unknown option \"$option\"" 551 } 552 set optdesc $classopt($option) 553 set type [lindex $optdesc 0] 554 if { [string equal $type "Synonym"] } { 555 set option [lindex $optdesc 1] 556 set optdesc $classopt($option) 557 set type [lindex $optdesc 0] 558 } 559 # this may fail if a wrong enum element was used 560 if {[catch { 561 $_optiontype($type) $option $value [lindex $optdesc 3] 562 } msg]} { 563 if {[info exists pathopt]} { 564 unset pathopt 565 } 566 unset pathmod 567 return -code error $msg 568 } 569 set pathopt($option) $msg 570 set pathinit($option) $pathopt($option) 571 } 572} 573 574# Bastien Chevreux (bach@mwgdna.com) 575# 576# copyinit performs basically the same job as init, but it uses a 577# existing template to initialize its values. So, first a perferct copy 578# from the template is made just to be altered by any existing options 579# afterwards. 580# But this still saves time as the first initialization parsing block is 581# skipped. 582# As additional bonus, items that differ in just a few options can be 583# initialized faster by leaving out the options that are equal. 584 585# This function is currently used only by ListBox::multipleinsert, but other 586# calls should follow :) 587 588# ---------------------------------------------------------------------------- 589# Command Widget::copyinit 590# ---------------------------------------------------------------------------- 591proc Widget::copyinit { class templatepath path options } { 592 variable _class 593 variable _optiontype 594 upvar 0 ${class}::opt classopt \ 595 ${class}::$path:opt pathopt \ 596 ${class}::$path:mod pathmod \ 597 ${class}::$path:init pathinit \ 598 ${class}::$templatepath:opt templatepathopt \ 599 ${class}::$templatepath:mod templatepathmod \ 600 ${class}::$templatepath:init templatepathinit 601 602 if { [info exists pathopt] } { 603 unset pathopt 604 } 605 if { [info exists pathmod] } { 606 unset pathmod 607 } 608 609 # We use the template widget for option db copying, but it has to exist! 610 array set pathmod [array get templatepathmod] 611 array set pathopt [array get templatepathopt] 612 array set pathinit [array get templatepathinit] 613 614 set _class($path) $class 615 foreach {option value} $options { 616 if { ![info exists classopt($option)] } { 617 unset pathopt 618 unset pathmod 619 return -code error "unknown option \"$option\"" 620 } 621 set optdesc $classopt($option) 622 set type [lindex $optdesc 0] 623 if { [string equal $type "Synonym"] } { 624 set option [lindex $optdesc 1] 625 set optdesc $classopt($option) 626 set type [lindex $optdesc 0] 627 } 628 set pathopt($option) [$_optiontype($type) $option $value [lindex $optdesc 3]] 629 set pathinit($option) $pathopt($option) 630 } 631} 632 633# Widget::parseArgs -- 634# 635# Given a widget class and a command-line spec, cannonize and validate 636# the given options, and return a keyed list consisting of the 637# component widget and its masked portion of the command-line spec, and 638# one extra entry consisting of the portion corresponding to the 639# megawidget itself. 640# 641# Arguments: 642# class widget class to parse for. 643# options command-line spec 644# 645# Results: 646# result keyed list of portions of the megawidget and that segment of 647# the command line in which that portion is interested. 648 649proc Widget::parseArgs {class options} { 650 variable _optiontype 651 upvar 0 ${class}::opt classopt 652 upvar 0 ${class}::map classmap 653 654 foreach {option val} $options { 655 if { ![info exists classopt($option)] } { 656 error "unknown option \"$option\"" 657 } 658 set optdesc $classopt($option) 659 set type [lindex $optdesc 0] 660 if { [string equal $type "Synonym"] } { 661 set option [lindex $optdesc 1] 662 set optdesc $classopt($option) 663 set type [lindex $optdesc 0] 664 } 665 if { [string equal $type "TkResource"] } { 666 # Make sure that the widget used for this TkResource exists 667 Widget::_get_tkwidget_options [lindex [lindex $optdesc 3] 0] 668 } 669 set val [$_optiontype($type) $option $val [lindex $optdesc 3]] 670 671 if { [info exists classmap($option)] } { 672 foreach {subpath subclass realopt} $classmap($option) { 673 lappend maps($subpath) $realopt $val 674 } 675 } else { 676 lappend maps($class) $option $val 677 } 678 } 679 return [array get maps] 680} 681 682# Widget::initFromODB -- 683# 684# Initialize a megawidgets options with information from the option 685# database and from the command-line arguments given. 686# 687# Arguments: 688# class class of the widget. 689# path path of the widget -- should already exist. 690# options command-line arguments. 691# 692# Results: 693# None. 694 695proc Widget::initFromODB {class path options} { 696 variable _inuse 697 variable _class 698 699 upvar 0 ${class}::$path:opt pathopt 700 upvar 0 ${class}::$path:mod pathmod 701 upvar 0 ${class}::map classmap 702 703 if { [info exists pathopt] } { 704 unset pathopt 705 } 706 if { [info exists pathmod] } { 707 unset pathmod 708 } 709 # We prefer to use the actual widget for option db queries, but if it 710 # doesn't exist yet, do the next best thing: create a widget of the 711 # same class and use that. 712 set fpath [_get_window $class $path] 713 set rdbclass [string map [list :: ""] $class] 714 if { ![winfo exists $path] } { 715 set fpath ".#BWidget.#Class#$class" 716 # encapsulation frame to not pollute '.' childspace 717 if {![winfo exists ".#BWidget"]} { frame ".#BWidget" } 718 if { ![winfo exists $fpath] } { 719 frame $fpath -class $rdbclass 720 } 721 } 722 723 foreach {option optdesc} [array get ${class}::opt] { 724 set pathmod($option) 0 725 if { [info exists classmap($option)] } { 726 continue 727 } 728 set type [lindex $optdesc 0] 729 if { [string equal $type "Synonym"] } { 730 continue 731 } 732 if { [string equal $type "TkResource"] } { 733 set alt [lindex [lindex $optdesc 3] 1] 734 } else { 735 set alt "" 736 } 737 set optdb [lindex [_configure_option $option $alt] 0] 738 set def [option get $fpath $optdb $rdbclass] 739 if { [string length $def] } { 740 set pathopt($option) $def 741 } else { 742 set pathopt($option) [lindex $optdesc 1] 743 } 744 } 745 746 if {![info exists _inuse($class)]} { set _inuse($class) 0 } 747 incr _inuse($class) 748 749 set _class($path) $class 750 array set pathopt $options 751} 752 753 754 755# ---------------------------------------------------------------------------- 756# Command Widget::destroy 757# ---------------------------------------------------------------------------- 758proc Widget::destroy { path } { 759 variable _class 760 variable _inuse 761 762 if {![info exists _class($path)]} { return } 763 764 set class $_class($path) 765 upvar 0 ${class}::$path:opt pathopt 766 upvar 0 ${class}::$path:mod pathmod 767 upvar 0 ${class}::$path:init pathinit 768 769 if {[info exists _inuse($class)]} { incr _inuse($class) -1 } 770 771 if {[info exists pathopt]} { 772 unset pathopt 773 } 774 if {[info exists pathmod]} { 775 unset pathmod 776 } 777 if {[info exists pathinit]} { 778 unset pathinit 779 } 780 781 if {![string equal [info commands $path] ""]} { rename $path "" } 782 783 ## Unset any variables used in this widget. 784 foreach var [info vars ::${class}::$path:*] { unset $var } 785 786 unset _class($path) 787} 788 789 790# ---------------------------------------------------------------------------- 791# Command Widget::configure 792# ---------------------------------------------------------------------------- 793proc Widget::configure { path options } { 794 set len [llength $options] 795 if { $len <= 1 } { 796 return [_get_configure $path $options] 797 } elseif { $len % 2 == 1 } { 798 return -code error "incorrect number of arguments" 799 } 800 801 variable _class 802 variable _optiontype 803 804 set class $_class($path) 805 upvar 0 ${class}::opt classopt 806 upvar 0 ${class}::map classmap 807 upvar 0 ${class}::$path:opt pathopt 808 upvar 0 ${class}::$path:mod pathmod 809 810 set window [_get_window $class $path] 811 foreach {option value} $options { 812 if { ![info exists classopt($option)] } { 813 return -code error "unknown option \"$option\"" 814 } 815 set optdesc $classopt($option) 816 set type [lindex $optdesc 0] 817 if { [string equal $type "Synonym"] } { 818 set option [lindex $optdesc 1] 819 set optdesc $classopt($option) 820 set type [lindex $optdesc 0] 821 } 822 if { ![lindex $optdesc 2] } { 823 set newval [$_optiontype($type) $option $value [lindex $optdesc 3]] 824 if { [info exists classmap($option)] } { 825 set window [_get_window $class $window] 826 foreach {subpath subclass realopt} $classmap($option) { 827 # Interpretation of special pointers: 828 # | subclass | subpath | widget | path | class | 829 # +----------+---------+------------------+----------------+-context-+ 830 # | :cmd | :cmd | herited widget | window:cmd |window | 831 # | :cmd | * | subwidget | window.subpath | window | 832 # | "" | :cmd | herited widget | window:cmd | window | 833 # | "" | * | own | window | window | 834 # | * | :cmd | own | window | current | 835 # | * | * | subwidget | window.subpath | current | 836 if { [string length $subclass] && ! [string equal $subclass ":cmd"] } { 837 if { [string equal $subpath ":cmd"] } { 838 set subpath "" 839 } 840 set curval [${subclass}::cget $window$subpath $realopt] 841 ${subclass}::configure $window$subpath $realopt $newval 842 } else { 843 set curval [$window$subpath cget $realopt] 844 $window$subpath configure $realopt $newval 845 } 846 } 847 } else { 848 set curval $pathopt($option) 849 set pathopt($option) $newval 850 } 851 set pathmod($option) [expr {![string equal $newval $curval]}] 852 } 853 } 854 855 return {} 856} 857 858 859# ---------------------------------------------------------------------------- 860# Command Widget::cget 861# ---------------------------------------------------------------------------- 862proc Widget::cget { path option } { 863 variable _class 864 if { ![info exists _class($path)] } { 865 return -code error "unknown widget $path" 866 } 867 868 set class $_class($path) 869 if { ![info exists ${class}::opt($option)] } { 870 return -code error "unknown option \"$option\"" 871 } 872 873 set optdesc [set ${class}::opt($option)] 874 set type [lindex $optdesc 0] 875 if {[string equal $type "Synonym"]} { 876 set option [lindex $optdesc 1] 877 } 878 879 if { [info exists ${class}::map($option)] } { 880 foreach {subpath subclass realopt} [set ${class}::map($option)] {break} 881 set path "[_get_window $class $path]$subpath" 882 883 set optval "" 884 if { [BWidget::using ttk] } { 885 # ttk 886 foreach {opt val} [::ttk::style configure .] { 887 if {$realopt eq $opt} { 888 set optval $val 889 break 890 } 891 } 892 } 893 # if ttk option doesn't exists, take tk option instead 894 if { [string length $optval] != 0 } { 895 return $optval 896 } else { return [$path cget $realopt] } 897 } 898 upvar 0 ${class}::$path:opt pathopt 899 set pathopt($option) 900} 901 902 903# ---------------------------------------------------------------------------- 904# Command Widget::subcget 905# ---------------------------------------------------------------------------- 906proc Widget::subcget { path subwidget } { 907 variable _class 908 set class $_class($path) 909 upvar 0 ${class}::$path:opt pathopt 910 upvar 0 ${class}::map$subwidget submap 911 upvar 0 ${class}::$path:init pathinit 912 913 set result {} 914 foreach realopt [array names submap] { 915 if { [info exists pathinit($submap($realopt))] } { 916 lappend result $realopt $pathopt($submap($realopt)) 917 } 918 } 919 return $result 920} 921 922 923# ---------------------------------------------------------------------------- 924# Command Widget::hasChanged 925# ---------------------------------------------------------------------------- 926proc Widget::hasChanged { path option pvalue } { 927 variable _class 928 upvar $pvalue value 929 set class $_class($path) 930 upvar 0 ${class}::$path:mod pathmod 931 932 set value [Widget::cget $path $option] 933 set result $pathmod($option) 934 set pathmod($option) 0 935 936 return $result 937} 938 939proc Widget::hasChangedX { path option args } { 940 variable _class 941 set class $_class($path) 942 upvar 0 ${class}::$path:mod pathmod 943 944 set result $pathmod($option) 945 set pathmod($option) 0 946 foreach option $args { 947 lappend result $pathmod($option) 948 set pathmod($option) 0 949 } 950 951 set result 952} 953 954 955# ---------------------------------------------------------------------------- 956# Command Widget::setoption 957# ---------------------------------------------------------------------------- 958proc Widget::setoption { path option value } { 959# variable _class 960 961# set class $_class($path) 962# upvar 0 ${class}::$path:opt pathopt 963 964# set pathopt($option) $value 965 Widget::configure $path [list $option $value] 966} 967 968 969# ---------------------------------------------------------------------------- 970# Command Widget::getoption 971# ---------------------------------------------------------------------------- 972proc Widget::getoption { path option } { 973# set class $::Widget::_class($path) 974# upvar 0 ${class}::$path:opt pathopt 975 976# return $pathopt($option) 977 return [Widget::cget $path $option] 978} 979 980# Widget::getMegawidgetOption -- 981# 982# Bypass the superfluous checks in cget and just directly peer at the 983# widget's data space. This is much more fragile than cget, so it 984# should only be used with great care, in places where speed is critical. 985# 986# Arguments: 987# path widget to lookup options for. 988# option option to retrieve. 989# 990# Results: 991# value option value. 992 993proc Widget::getMegawidgetOption {path option} { 994 variable _class 995 set class $_class($path) 996 upvar 0 ${class}::${path}:opt pathopt 997 set pathopt($option) 998} 999 1000# Widget::setMegawidgetOption -- 1001# 1002# Bypass the superfluous checks in cget and just directly poke at the 1003# widget's data space. This is much more fragile than configure, so it 1004# should only be used with great care, in places where speed is critical. 1005# 1006# Arguments: 1007# path widget to lookup options for. 1008# option option to retrieve. 1009# value option value. 1010# 1011# Results: 1012# value option value. 1013 1014proc Widget::setMegawidgetOption {path option value} { 1015 variable _class 1016 set class $_class($path) 1017 upvar 0 ${class}::${path}:opt pathopt 1018 set pathopt($option) $value 1019} 1020 1021# ---------------------------------------------------------------------------- 1022# Command Widget::_get_window 1023# returns the window corresponding to widget path 1024# ---------------------------------------------------------------------------- 1025proc Widget::_get_window { class path } { 1026 set idx [string last "#" $path] 1027 if { $idx != -1 && [string equal [string range $path [expr {$idx+1}] end] $class] } { 1028 return [string range $path 0 [expr {$idx-1}]] 1029 } else { 1030 return $path 1031 } 1032} 1033 1034 1035# ---------------------------------------------------------------------------- 1036# Command Widget::_get_configure 1037# returns the configuration list of options 1038# (as tk widget do - [$w configure ?option?]) 1039# ---------------------------------------------------------------------------- 1040proc Widget::_get_configure { path options } { 1041 variable _class 1042 1043 set class $_class($path) 1044 upvar 0 ${class}::opt classopt 1045 upvar 0 ${class}::map classmap 1046 upvar 0 ${class}::$path:opt pathopt 1047 upvar 0 ${class}::$path:mod pathmod 1048 1049 set len [llength $options] 1050 if { !$len } { 1051 set result {} 1052 foreach option [lsort [array names classopt]] { 1053 set optdesc $classopt($option) 1054 set type [lindex $optdesc 0] 1055 if { [string equal $type "Synonym"] } { 1056 set syn $option 1057 set option [lindex $optdesc 1] 1058 set optdesc $classopt($option) 1059 set type [lindex $optdesc 0] 1060 } else { 1061 set syn "" 1062 } 1063 if { [string equal $type "TkResource"] } { 1064 set alt [lindex [lindex $optdesc 3] 1] 1065 } else { 1066 set alt "" 1067 } 1068 set res [_configure_option $option $alt] 1069 if { $syn == "" } { 1070 lappend result [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]] 1071 } else { 1072 lappend result [list $syn [lindex $res 0]] 1073 } 1074 } 1075 return $result 1076 } elseif { $len == 1 } { 1077 set option [lindex $options 0] 1078 if { ![info exists classopt($option)] } { 1079 return -code error "unknown option \"$option\"" 1080 } 1081 set optdesc $classopt($option) 1082 set type [lindex $optdesc 0] 1083 if { [string equal $type "Synonym"] } { 1084 set option [lindex $optdesc 1] 1085 set optdesc $classopt($option) 1086 set type [lindex $optdesc 0] 1087 } 1088 if { [string equal $type "TkResource"] } { 1089 set alt [lindex [lindex $optdesc 3] 1] 1090 } else { 1091 set alt "" 1092 } 1093 set res [_configure_option $option $alt] 1094 return [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]] 1095 } 1096} 1097 1098 1099# ---------------------------------------------------------------------------- 1100# Command Widget::_configure_option 1101# ---------------------------------------------------------------------------- 1102proc Widget::_configure_option { option altopt } { 1103 variable _optiondb 1104 variable _optionclass 1105 1106 if { [info exists _optiondb($option)] } { 1107 set optdb $_optiondb($option) 1108 } else { 1109 set optdb [string range $option 1 end] 1110 } 1111 if { [info exists _optionclass($option)] } { 1112 set optclass $_optionclass($option) 1113 } elseif { [string length $altopt] } { 1114 if { [info exists _optionclass($altopt)] } { 1115 set optclass $_optionclass($altopt) 1116 } else { 1117 set optclass [string range $altopt 1 end] 1118 } 1119 } else { 1120 set optclass [string range $option 1 end] 1121 } 1122 return [list $optdb $optclass] 1123} 1124 1125 1126# ---------------------------------------------------------------------------- 1127# Command Widget::_get_tkwidget_options 1128# ---------------------------------------------------------------------------- 1129proc Widget::_get_tkwidget_options { tkwidget } { 1130 variable _tk_widget 1131 variable _optiondb 1132 variable _optionclass 1133 1134 set widget ".#BWidget.#$tkwidget" 1135 # encapsulation frame to not pollute '.' childspace 1136 if {![winfo exists ".#BWidget"]} { frame ".#BWidget" } 1137 if { ![winfo exists $widget] || ![info exists _tk_widget($tkwidget)] } { 1138 set widget [$tkwidget $widget] 1139 # JDC: Withdraw toplevels, otherwise visible 1140 if {[string equal $tkwidget "toplevel"]} { 1141 wm withdraw $widget 1142 } 1143 set config [$widget configure] 1144 foreach optlist $config { 1145 set opt [lindex $optlist 0] 1146 if { [llength $optlist] == 2 } { 1147 set refsyn [lindex $optlist 1] 1148 # search for class 1149 set idx [lsearch $config [list * $refsyn *]] 1150 if { $idx == -1 } { 1151 if { [string index $refsyn 0] == "-" } { 1152 # search for option (tk8.1b1 bug) 1153 set idx [lsearch $config [list $refsyn * *]] 1154 } else { 1155 # last resort 1156 set idx [lsearch $config [list -[string tolower $refsyn] * *]] 1157 } 1158 if { $idx == -1 } { 1159 # fed up with "can't read classopt()" 1160 return -code error "can't find option of synonym $opt" 1161 } 1162 } 1163 set syn [lindex [lindex $config $idx] 0] 1164 # JDC: used 4 (was 3) to get def from optiondb 1165 set def [lindex [lindex $config $idx] 4] 1166 lappend _tk_widget($tkwidget) [list $opt $syn $def] 1167 } else { 1168 # JDC: used 4 (was 3) to get def from optiondb 1169 set def [lindex $optlist 4] 1170 lappend _tk_widget($tkwidget) [list $opt $def] 1171 set _optiondb($opt) [lindex $optlist 1] 1172 set _optionclass($opt) [lindex $optlist 2] 1173 } 1174 } 1175 } 1176 return $_tk_widget($tkwidget) 1177} 1178 1179 1180# ---------------------------------------------------------------------------- 1181# Command Widget::_test_tkresource 1182# ---------------------------------------------------------------------------- 1183proc Widget::_test_tkresource { option value arg } { 1184# set tkwidget [lindex $arg 0] 1185# set realopt [lindex $arg 1] 1186 foreach {tkwidget realopt} $arg break 1187 set path ".#BWidget.#$tkwidget" 1188 set old [$path cget $realopt] 1189 $path configure $realopt $value 1190 set res [$path cget $realopt] 1191 $path configure $realopt $old 1192 1193 return $res 1194} 1195 1196 1197# ---------------------------------------------------------------------------- 1198# Command Widget::_test_bwresource 1199# ---------------------------------------------------------------------------- 1200proc Widget::_test_bwresource { option value arg } { 1201 return -code error "bad option type BwResource in widget" 1202} 1203 1204 1205# ---------------------------------------------------------------------------- 1206# Command Widget::_test_synonym 1207# ---------------------------------------------------------------------------- 1208proc Widget::_test_synonym { option value arg } { 1209 return -code error "bad option type Synonym in widget" 1210} 1211 1212# ---------------------------------------------------------------------------- 1213# Command Widget::_test_color 1214# ---------------------------------------------------------------------------- 1215proc Widget::_test_color { option value arg } { 1216 if {[catch {winfo rgb . $value} color]} { 1217 return -code error "bad $option value \"$value\": must be a colorname \ 1218 or #RRGGBB triplet" 1219 } 1220 1221 return $value 1222} 1223 1224 1225# ---------------------------------------------------------------------------- 1226# Command Widget::_test_string 1227# ---------------------------------------------------------------------------- 1228proc Widget::_test_string { option value arg } { 1229 set value 1230} 1231 1232 1233# ---------------------------------------------------------------------------- 1234# Command Widget::_test_flag 1235# ---------------------------------------------------------------------------- 1236proc Widget::_test_flag { option value arg } { 1237 set len [string length $value] 1238 set res "" 1239 for {set i 0} {$i < $len} {incr i} { 1240 set c [string index $value $i] 1241 if { [string first $c $arg] == -1 } { 1242 return -code error "bad [string range $option 1 end] value \"$value\": characters must be in \"$arg\"" 1243 } 1244 if { [string first $c $res] == -1 } { 1245 append res $c 1246 } 1247 } 1248 return $res 1249} 1250 1251 1252# ----------------------------------------------------------------------------- 1253# Command Widget::_test_enum 1254# ----------------------------------------------------------------------------- 1255proc Widget::_test_enum { option value arg } { 1256 if { [lsearch $arg $value] == -1 } { 1257 set last [lindex $arg end] 1258 set sub [lreplace $arg end end] 1259 if { [llength $sub] } { 1260 set str "[join $sub ", "] or $last" 1261 } else { 1262 set str $last 1263 } 1264 return -code error "bad [string range $option 1 end] value \"$value\": must be $str" 1265 } 1266 return $value 1267} 1268 1269 1270# ----------------------------------------------------------------------------- 1271# Command Widget::_test_int 1272# ----------------------------------------------------------------------------- 1273proc Widget::_test_int { option value arg } { 1274 if { ![string is int -strict $value] || \ 1275 ([string length $arg] && \ 1276 ![expr [string map [list %d $value] $arg]]) } { 1277 return -code error "bad $option value\ 1278 \"$value\": must be integer ($arg)" 1279 } 1280 return $value 1281} 1282 1283 1284# ----------------------------------------------------------------------------- 1285# Command Widget::_test_boolean 1286# ----------------------------------------------------------------------------- 1287proc Widget::_test_boolean { option value arg } { 1288 if { ![string is boolean -strict $value] } { 1289 return -code error "bad $option value \"$value\": must be boolean" 1290 } 1291 1292 # Get the canonical form of the boolean value (1 for true, 0 for false) 1293 return [string is true $value] 1294} 1295 1296 1297# ----------------------------------------------------------------------------- 1298# Command Widget::_test_padding 1299# ----------------------------------------------------------------------------- 1300proc Widget::_test_padding { option values arg } { 1301 set len [llength $values] 1302 if {$len < 1 || $len > 2} { 1303 return -code error "bad pad value \"$values\":\ 1304 must be positive screen distance" 1305 } 1306 1307 foreach value $values { 1308 if { ![string is int -strict $value] || \ 1309 ([string length $arg] && \ 1310 ![expr [string map [list %d $value] $arg]]) } { 1311 return -code error "bad pad value \"$value\":\ 1312 must be positive screen distance ($arg)" 1313 } 1314 } 1315 return $values 1316} 1317 1318 1319# Widget::_get_padding -- 1320# 1321# Return the requesting padding value for a padding option. 1322# 1323# Arguments: 1324# path Widget to get the options for. 1325# option The name of the padding option. 1326# index The index of the padding. If the index is empty, 1327# the first padding value is returned. 1328# 1329# Results: 1330# Return a numeric value that can be used for padding. 1331proc Widget::_get_padding { path option {index 0} } { 1332 set pad [Widget::cget $path $option] 1333 set val [lindex $pad $index] 1334 if {$val == ""} { set val [lindex $pad 0] } 1335 return $val 1336} 1337 1338 1339# ----------------------------------------------------------------------------- 1340# Command Widget::focusNext 1341# Same as tk_focusNext, but call Widget::focusOK 1342# ----------------------------------------------------------------------------- 1343proc Widget::focusNext { w } { 1344 set cur $w 1345 while 1 { 1346 1347 # Descend to just before the first child of the current widget. 1348 1349 set parent $cur 1350 set children [winfo children $cur] 1351 set i -1 1352 1353 # Look for the next sibling that isn't a top-level. 1354 1355 while 1 { 1356 incr i 1357 if {$i < [llength $children]} { 1358 set cur [lindex $children $i] 1359 if {[string equal [winfo toplevel $cur] $cur]} { 1360 continue 1361 } else { 1362 break 1363 } 1364 } 1365 1366 # No more siblings, so go to the current widget's parent. 1367 # If it's a top-level, break out of the loop, otherwise 1368 # look for its next sibling. 1369 1370 set cur $parent 1371 if {[string equal [winfo toplevel $cur] $cur]} { 1372 break 1373 } 1374 set parent [winfo parent $parent] 1375 set children [winfo children $parent] 1376 set i [lsearch -exact $children $cur] 1377 } 1378 if {[string equal $cur $w] || [focusOK $cur]} { 1379 return $cur 1380 } 1381 } 1382} 1383 1384 1385# ----------------------------------------------------------------------------- 1386# Command Widget::focusPrev 1387# Same as tk_focusPrev, except: 1388# + Don't traverse from a child to a direct ancestor 1389# + Call Widget::focusOK instead of tk::focusOK 1390# ----------------------------------------------------------------------------- 1391proc Widget::focusPrev { w } { 1392 set cur $w 1393 set origParent [winfo parent $w] 1394 while 1 { 1395 1396 # Collect information about the current window's position 1397 # among its siblings. Also, if the window is a top-level, 1398 # then reposition to just after the last child of the window. 1399 1400 if {[string equal [winfo toplevel $cur] $cur]} { 1401 set parent $cur 1402 set children [winfo children $cur] 1403 set i [llength $children] 1404 } else { 1405 set parent [winfo parent $cur] 1406 set children [winfo children $parent] 1407 set i [lsearch -exact $children $cur] 1408 } 1409 1410 # Go to the previous sibling, then descend to its last descendant 1411 # (highest in stacking order. While doing this, ignore top-levels 1412 # and their descendants. When we run out of descendants, go up 1413 # one level to the parent. 1414 1415 while {$i > 0} { 1416 incr i -1 1417 set cur [lindex $children $i] 1418 if {[string equal [winfo toplevel $cur] $cur]} { 1419 continue 1420 } 1421 set parent $cur 1422 set children [winfo children $parent] 1423 set i [llength $children] 1424 } 1425 set cur $parent 1426 if {[string equal $cur $w]} { 1427 return $cur 1428 } 1429 # If we are just at the original parent of $w, skip it as a 1430 # potential focus accepter. Extra safety in this is to see if 1431 # that parent is also a proc (not a C command), which is what 1432 # BWidgets makes for any megawidget. Could possibly also check 1433 # for '[info commands ::${origParent}:cmd] != ""'. [Bug 765667] 1434 if {[string equal $cur $origParent] 1435 && [info procs ::$origParent] != ""} { 1436 continue 1437 } 1438 if {[focusOK $cur]} { 1439 return $cur 1440 } 1441 } 1442} 1443 1444 1445# ---------------------------------------------------------------------------- 1446# Command Widget::focusOK 1447# Same as tk_focusOK, but handles -editable option and whole tags list. 1448# ---------------------------------------------------------------------------- 1449proc Widget::focusOK { w } { 1450 set code [catch {$w cget -takefocus} value] 1451 if { $code == 1 } { 1452 return 0 1453 } 1454 if {($code == 0) && ($value != "")} { 1455 if {$value == 0} { 1456 return 0 1457 } elseif {$value == 1} { 1458 return [winfo viewable $w] 1459 } else { 1460 set value [uplevel \#0 $value $w] 1461 if {$value != ""} { 1462 return $value 1463 } 1464 } 1465 } 1466 if {![winfo viewable $w]} { 1467 return 0 1468 } 1469 set code [catch {$w cget -state} value] 1470 if {($code == 0) && ($value == "disabled")} { 1471 return 0 1472 } 1473 set code [catch {$w cget -editable} value] 1474 if {($code == 0) && ($value == 0)} { 1475 return 0 1476 } 1477 1478 set top [winfo toplevel $w] 1479 foreach tags [bindtags $w] { 1480 if { ![string equal $tags $top] && 1481 ![string equal $tags "all"] && 1482 [regexp Key [bind $tags]] } { 1483 return 1 1484 } 1485 } 1486 return 0 1487} 1488 1489 1490proc Widget::traverseTo { w } { 1491 set focus [focus] 1492 if {![string equal $focus ""]} { 1493 event generate $focus <<TraverseOut>> 1494 } 1495 focus $w 1496 1497 event generate $w <<TraverseIn>> 1498} 1499 1500 1501# Widget::varForOption -- 1502# 1503# Retrieve a fully qualified variable name for the option specified. 1504# If the option is not one for which a variable exists, throw an error 1505# (ie, those options that map directly to widget options). 1506# 1507# Arguments: 1508# path megawidget to get an option var for. 1509# option option to get a var for. 1510# 1511# Results: 1512# varname name of the variable, fully qualified, suitable for tracing. 1513 1514proc Widget::varForOption {path option} { 1515 variable _class 1516 variable _optiontype 1517 1518 set class $_class($path) 1519 upvar 0 ${class}::$path:opt pathopt 1520 1521 if { ![info exists pathopt($option)] } { 1522 error "unable to find variable for option \"$option\"" 1523 } 1524 set varname "::Widget::${class}::$path:opt($option)" 1525 return $varname 1526} 1527 1528# Widget::getVariable -- 1529# 1530# Get a variable from within the namespace of the widget. 1531# 1532# Arguments: 1533# path Megawidget to get the variable for. 1534# varName The variable name to retrieve. 1535# newVarName The variable name to refer to in the calling proc. 1536# 1537# Results: 1538# Creates a reference to newVarName in the calling proc. 1539proc Widget::getVariable { path varName {newVarName ""} } { 1540 variable _class 1541 set class $_class($path) 1542 if {![string length $newVarName]} { set newVarName $varName } 1543 uplevel 1 [list upvar \#0 ${class}::$path:$varName $newVarName] 1544} 1545 1546# Widget::options -- 1547# 1548# Return a key-value list of options for a widget. This can 1549# be used to serialize the options of a widget and pass them 1550# on to a new widget with the same options. 1551# 1552# Arguments: 1553# path Widget to get the options for. 1554# args A list of options. If empty, all options are returned. 1555# 1556# Results: 1557# Returns list of options as: -option value -option value ... 1558proc Widget::options { path args } { 1559 if {[llength $args]} { 1560 foreach option $args { 1561 lappend options [_get_configure $path $option] 1562 } 1563 } else { 1564 set options [_get_configure $path {}] 1565 } 1566 1567 set result [list] 1568 foreach list $options { 1569 if {[llength $list] < 5} { continue } 1570 lappend result [lindex $list 0] [lindex $list end] 1571 } 1572 return $result 1573} 1574 1575 1576# Widget::getOption -- 1577# 1578# Given a list of widgets, determine which option value to use. 1579# The widgets are given to the command in order of highest to 1580# lowest. Starting with the lowest widget, whichever one does 1581# not match the default option value is returned as the value. 1582# If all the widgets are default, we return the highest widget's 1583# value. 1584# 1585# Arguments: 1586# option The option to check. 1587# default The default value. If any widget in the list 1588# does not match this default, its value is used. 1589# args A list of widgets. 1590# 1591# Results: 1592# Returns the value of the given option to use. 1593# 1594proc Widget::getOption { option default args } { 1595 for {set i [expr [llength $args] -1]} {$i >= 0} {incr i -1} { 1596 set widget [lindex $args $i] 1597 set value [Widget::cget $widget $option] 1598 if {[string equal $value $default]} { continue } 1599 return $value 1600 } 1601 return $value 1602} 1603 1604 1605proc Widget::nextIndex { path node } { 1606 Widget::getVariable $path autoIndex 1607 if {![info exists autoIndex]} { set autoIndex -1 } 1608 return [string map [list #auto [incr autoIndex]] $node] 1609} 1610 1611 1612proc Widget::exists { path } { 1613 variable _class 1614 return [info exists _class($path)] 1615} 1616 1617# deprecated, use "BWidget::use" instead! 1618proc Widget::theme {{bool {}}} { 1619 # Private, *experimental* API that may change at any time - JH 1620 variable _theme 1621 if {[llength [info level 0]] == 2} { 1622 # set theme-ability 1623 if { [catch {package require Tk 8.4.7}] 1624 && [catch {package require tile 0.8}] } { 1625 return -code error "BWidget's theming requires tile 0.8+" 1626 } 1627 set _theme [string is true -strict $bool] 1628 } 1629 return $_theme 1630} 1631 1632 1633#------------------------------------------------------------------------------ 1634# remove {keystr value} sub list from args 1635# arg contains the associated value of keystr, or an empty string 1636# while loop ensures to remove all matches of keystr 1637#------------------------------------------------------------------------------ 1638proc Widget::getArgument {args keystr arg} { 1639 upvar $arg cvalue 1640 set cvalue "" 1641 while {[set i [lsearch -exact $args $keystr]] >= 0} { 1642 set j [expr $i + 1] 1643 set cvalue [lindex $args $j] 1644 set args [lreplace $args $i $j] 1645 } 1646 return $args 1647} 1648 1649 1650proc Widget::getallwidgets {{w .}} { 1651 set rlist [list $w] 1652 foreach c [winfo children $w] { 1653 set rlist [concat $rlist [getallwidgets $c]] 1654 } 1655 return $rlist 1656} 1657