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