1# ---------------------------------------------------------------------------- 2# progressbar.tcl 3# This file is part of Unifix BWidget Toolkit 4# ---------------------------------------------------------------------------- 5# Index of commands: 6# - ProgressBar::create 7# - ProgressBar::configure 8# - ProgressBar::cget 9# - ProgressBar::_destroy 10# - ProgressBar::_modify 11# ---------------------------------------------------------------------------- 12 13package provide PBar 1.0 14 15# ---------------------------------------------------------------------------- 16# utils.tcl 17# This file is part of Unifix BWidget Toolkit 18# $Id: utils.tcl,v 1.12 2004/09/24 23:57:13 hobbs Exp $ 19# ---------------------------------------------------------------------------- 20# Index of commands: 21# - GlobalVar::exists 22# - GlobalVar::setvarvar 23# - GlobalVar::getvarvar 24# - BWidget::assert 25# - BWidget::clonename 26# - BWidget::get3dcolor 27# - BWidget::XLFDfont 28# - BWidget::place 29# - BWidget::grab 30# - BWidget::focus 31# ---------------------------------------------------------------------------- 32 33namespace eval GlobalVar { 34 proc use {} {} 35} 36 37 38namespace eval BWidget { 39 variable _top 40 variable _gstack {} 41 variable _fstack {} 42 proc use {} {} 43} 44 45 46# ---------------------------------------------------------------------------- 47# Command GlobalVar::exists 48# ---------------------------------------------------------------------------- 49proc GlobalVar::exists { varName } { 50 return [uplevel \#0 [list info exists $varName]] 51} 52 53 54# ---------------------------------------------------------------------------- 55# Command GlobalVar::setvar 56# ---------------------------------------------------------------------------- 57proc GlobalVar::setvar { varName value } { 58 return [uplevel \#0 [list set $varName $value]] 59} 60 61 62# ---------------------------------------------------------------------------- 63# Command GlobalVar::getvar 64# ---------------------------------------------------------------------------- 65proc GlobalVar::getvar { varName } { 66 return [uplevel \#0 [list set $varName]] 67} 68 69 70# ---------------------------------------------------------------------------- 71# Command GlobalVar::tracevar 72# ---------------------------------------------------------------------------- 73proc GlobalVar::tracevar { cmd varName args } { 74 return [uplevel \#0 [list trace $cmd $varName] $args] 75} 76 77 78 79# ---------------------------------------------------------------------------- 80# Command BWidget::lreorder 81# ---------------------------------------------------------------------------- 82proc BWidget::lreorder { list neworder } { 83 set pos 0 84 set newlist {} 85 foreach e $neworder { 86 if { [lsearch -exact $list $e] != -1 } { 87 lappend newlist $e 88 set tabelt($e) 1 89 } 90 } 91 set len [llength $newlist] 92 if { !$len } { 93 return $list 94 } 95 if { $len == [llength $list] } { 96 return $newlist 97 } 98 set pos 0 99 foreach e $list { 100 if { ![info exists tabelt($e)] } { 101 set newlist [linsert $newlist $pos $e] 102 } 103 incr pos 104 } 105 return $newlist 106} 107 108 109# ---------------------------------------------------------------------------- 110# Command BWidget::assert 111# ---------------------------------------------------------------------------- 112proc BWidget::assert { exp {msg ""}} { 113 set res [uplevel 1 expr $exp] 114 if { !$res} { 115 if { $msg == "" } { 116 return -code error "Assertion failed: {$exp}" 117 } else { 118 return -code error $msg 119 } 120 } 121} 122 123 124# ---------------------------------------------------------------------------- 125# Command BWidget::clonename 126# ---------------------------------------------------------------------------- 127proc BWidget::clonename { menu } { 128 set path "" 129 set menupath "" 130 set found 0 131 foreach widget [lrange [split $menu "."] 1 end] { 132 if { $found || [winfo class "$path.$widget"] == "Menu" } { 133 set found 1 134 append menupath "#" $widget 135 append path "." $menupath 136 } else { 137 append menupath "#" $widget 138 append path "." $widget 139 } 140 } 141 return $path 142} 143 144 145# ---------------------------------------------------------------------------- 146# Command BWidget::getname 147# ---------------------------------------------------------------------------- 148proc BWidget::getname { name } { 149 if { [string length $name] } { 150 set text [option get . "${name}Name" ""] 151 if { [string length $text] } { 152 return [parsetext $text] 153 } 154 } 155 return {} 156 } 157 158 159# ---------------------------------------------------------------------------- 160# Command BWidget::parsetext 161# ---------------------------------------------------------------------------- 162proc BWidget::parsetext { text } { 163 set result "" 164 set index -1 165 set start 0 166 while { [string length $text] } { 167 set idx [string first "&" $text] 168 if { $idx == -1 } { 169 append result $text 170 set text "" 171 } else { 172 set char [string index $text [expr {$idx+1}]] 173 if { $char == "&" } { 174 append result [string range $text 0 $idx] 175 set text [string range $text [expr {$idx+2}] end] 176 set start [expr {$start+$idx+1}] 177 } else { 178 append result [string range $text 0 [expr {$idx-1}]] 179 set text [string range $text [expr {$idx+1}] end] 180 incr start $idx 181 set index $start 182 } 183 } 184 } 185 return [list $result $index] 186} 187 188 189# ---------------------------------------------------------------------------- 190# Command BWidget::get3dcolor 191# ---------------------------------------------------------------------------- 192proc BWidget::get3dcolor { path bgcolor } { 193 foreach val [winfo rgb $path $bgcolor] { 194 lappend dark [expr {60*$val/100}] 195 set tmp1 [expr {14*$val/10}] 196 if { $tmp1 > 65535 } { 197 set tmp1 65535 198 } 199 set tmp2 [expr {(65535+$val)/2}] 200 lappend light [expr {($tmp1 > $tmp2) ? $tmp1:$tmp2}] 201 } 202 return [list [eval format "#%04x%04x%04x" $dark] [eval format "#%04x%04x%04x" $light]] 203} 204 205 206# ---------------------------------------------------------------------------- 207# Command BWidget::XLFDfont 208# ---------------------------------------------------------------------------- 209proc BWidget::XLFDfont { cmd args } { 210 switch -- $cmd { 211 create { 212 set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*" 213 } 214 configure { 215 set font [lindex $args 0] 216 set args [lrange $args 1 end] 217 } 218 default { 219 return -code error "XLFDfont: commande incorrect: $cmd" 220 } 221 } 222 set lfont [split $font "-"] 223 if { [llength $lfont] != 15 } { 224 return -code error "XLFDfont: description XLFD incorrect: $font" 225 } 226 227 foreach {option value} $args { 228 switch -- $option { 229 -foundry { set index 1 } 230 -family { set index 2 } 231 -weight { set index 3 } 232 -slant { set index 4 } 233 -size { set index 7 } 234 default { return -code error "XLFDfont: option incorrecte: $option" } 235 } 236 set lfont [lreplace $lfont $index $index $value] 237 } 238 return [join $lfont "-"] 239} 240 241 242 243# ---------------------------------------------------------------------------- 244# Command BWidget::place 245# ---------------------------------------------------------------------------- 246# 247# Notes: 248# For Windows systems with more than one monitor the available screen area may 249# have negative positions. Geometry settings with negative numbers are used 250# under X to place wrt the right or bottom of the screen. On windows, Tk 251# continues to do this. However, a geometry such as 100x100+-200-100 can be 252# used to place a window onto a secondary monitor. Passing the + gets Tk 253# to pass the remainder unchanged so the Windows manager then handles -200 254# which is a position on the left hand monitor. 255# I've tested this for left, right, above and below the primary monitor. 256# Currently there is no way to ask Tk the extent of the Windows desktop in 257# a multi monitor system. Nor what the legal co-ordinate range might be. 258# 259proc BWidget::place { path w h args } { 260 variable _top 261 262 update idletasks 263 set reqw [winfo reqwidth $path] 264 set reqh [winfo reqheight $path] 265 if { $w == 0 } {set w $reqw} 266 if { $h == 0 } {set h $reqh} 267 268 set arglen [llength $args] 269 if { $arglen > 3 } { 270 return -code error "BWidget::place: bad number of argument" 271 } 272 273 if { $arglen > 0 } { 274 set where [lindex $args 0] 275 set list [list "at" "center" "left" "right" "above" "below"] 276 set idx [lsearch $list $where] 277 if { $idx == -1 } { 278 return -code error [BWidget::badOptionString position $where $list] 279 } 280 if { $idx == 0 } { 281 set err [catch { 282 # purposely removed the {} around these expressions - [PT] 283 set x [expr int([lindex $args 1])] 284 set y [expr int([lindex $args 2])] 285 }] 286 if { $err } { 287 return -code error "BWidget::place: incorrect position" 288 } 289 if {$::tcl_platform(platform) == "windows"} { 290 # handle windows multi-screen. -100 != +-100 291 if {[string index [lindex $args 1] 0] != "-"} { 292 set x "+$x" 293 } 294 if {[string index [lindex $args 2] 0] != "-"} { 295 set y "+$y" 296 } 297 } else { 298 if { $x >= 0 } { 299 set x "+$x" 300 } 301 if { $y >= 0 } { 302 set y "+$y" 303 } 304 } 305 } else { 306 if { $arglen == 2 } { 307 set widget [lindex $args 1] 308 if { ![winfo exists $widget] } { 309 return -code error "BWidget::place: \"$widget\" does not exist" 310 } 311 } else { 312 set widget . 313 } 314 set sw [winfo screenwidth $path] 315 set sh [winfo screenheight $path] 316 if { $idx == 1 } { 317 if { $arglen == 2 } { 318 # center to widget 319 set x0 [expr {[winfo rootx $widget] + ([winfo width $widget] - $w)/2}] 320 set y0 [expr {[winfo rooty $widget] + ([winfo height $widget] - $h)/2}] 321 } else { 322 # center to screen 323 set x0 [expr {([winfo screenwidth $path] - $w)/2 - [winfo vrootx $path]}] 324 set y0 [expr {([winfo screenheight $path] - $h)/2 - [winfo vrooty $path]}] 325 } 326 set x "+$x0" 327 set y "+$y0" 328 if {$::tcl_platform(platform) != "windows"} { 329 if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]} 330 if { $x0 < 0 } {set x "+0"} 331 if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]} 332 if { $y0 < 0 } {set y "+0"} 333 } 334 } else { 335 set x0 [winfo rootx $widget] 336 set y0 [winfo rooty $widget] 337 set x1 [expr {$x0 + [winfo width $widget]}] 338 set y1 [expr {$y0 + [winfo height $widget]}] 339 if { $idx == 2 || $idx == 3 } { 340 set y "+$y0" 341 if {$::tcl_platform(platform) != "windows"} { 342 if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]} 343 if { $y0 < 0 } {set y "+0"} 344 } 345 if { $idx == 2 } { 346 # try left, then right if out, then 0 if out 347 if { $x0 >= $w } { 348 set x [expr {$x0-$sw}] 349 } elseif { $x1+$w <= $sw } { 350 set x "+$x1" 351 } else { 352 set x "+0" 353 } 354 } else { 355 # try right, then left if out, then 0 if out 356 if { $x1+$w <= $sw } { 357 set x "+$x1" 358 } elseif { $x0 >= $w } { 359 set x [expr {$x0-$sw}] 360 } else { 361 set x "-0" 362 } 363 } 364 } else { 365 set x "+$x0" 366 if {$::tcl_platform(platform) != "windows"} { 367 if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]} 368 if { $x0 < 0 } {set x "+0"} 369 } 370 if { $idx == 4 } { 371 # try top, then bottom, then 0 372 if { $h <= $y0 } { 373 set y [expr {$y0-$sh}] 374 } elseif { $y1+$h <= $sh } { 375 set y "+$y1" 376 } else { 377 set y "+0" 378 } 379 } else { 380 # try bottom, then top, then 0 381 if { $y1+$h <= $sh } { 382 set y "+$y1" 383 } elseif { $h <= $y0 } { 384 set y [expr {$y0-$sh}] 385 } else { 386 set y "-0" 387 } 388 } 389 } 390 } 391 } 392 393 ## If there's not a + or - in front of the number, we need to add one. 394 if {[string is integer [string index $x 0]]} { set x +$x } 395 if {[string is integer [string index $y 0]]} { set y +$y } 396 397 wm geometry $path "${w}x${h}${x}${y}" 398 } else { 399 wm geometry $path "${w}x${h}" 400 } 401 update idletasks 402} 403 404 405# ---------------------------------------------------------------------------- 406# Command BWidget::grab 407# ---------------------------------------------------------------------------- 408proc BWidget::grab { option path } { 409 variable _gstack 410 411 if { $option == "release" } { 412 catch {::grab release $path} 413 while { [llength $_gstack] } { 414 set grinfo [lindex $_gstack end] 415 set _gstack [lreplace $_gstack end end] 416 foreach {oldg mode} $grinfo { 417 if { ![string equal $oldg $path] && [winfo exists $oldg] } { 418 if { $mode == "global" } { 419 catch {::grab -global $oldg} 420 } else { 421 catch {::grab $oldg} 422 } 423 return 424 } 425 } 426 } 427 } else { 428 set oldg [::grab current] 429 if { $oldg != "" } { 430 lappend _gstack [list $oldg [::grab status $oldg]] 431 } 432 if { $option == "global" } { 433 ::grab -global $path 434 } else { 435 ::grab $path 436 } 437 } 438} 439 440 441# ---------------------------------------------------------------------------- 442# Command BWidget::focus 443# ---------------------------------------------------------------------------- 444proc BWidget::focus { option path {refocus 1} } { 445 variable _fstack 446 447 if { $option == "release" } { 448 while { [llength $_fstack] } { 449 set oldf [lindex $_fstack end] 450 set _fstack [lreplace $_fstack end end] 451 if { ![string equal $oldf $path] && [winfo exists $oldf] } { 452 if {$refocus} {catch {::focus -force $oldf}} 453 return 454 } 455 } 456 } elseif { $option == "set" } { 457 lappend _fstack [::focus] 458 ::focus -force $path 459 } 460} 461 462# BWidget::refocus -- 463# 464# Helper function used to redirect focus from a container frame in 465# a megawidget to a component widget. Only redirects focus if 466# focus is already on the container. 467# 468# Arguments: 469# container container widget to redirect from. 470# component component widget to redirect to. 471# 472# Results: 473# None. 474 475proc BWidget::refocus {container component} { 476 if { [string equal $container [::focus]] } { 477 ::focus $component 478 } 479 return 480} 481 482## These mirror tk::(Set|Restore)FocusGrab 483 484# BWidget::SetFocusGrab -- 485# swap out current focus and grab temporarily (for dialogs) 486# Arguments: 487# grab new window to grab 488# focus window to give focus to 489# Results: 490# Returns nothing 491# 492proc BWidget::SetFocusGrab {grab {focus {}}} { 493 variable _focusGrab 494 set index "$grab,$focus" 495 496 lappend _focusGrab($index) [::focus] 497 set oldGrab [::grab current $grab] 498 lappend _focusGrab($index) $oldGrab 499 if {[winfo exists $oldGrab]} { 500 lappend _focusGrab($index) [::grab status $oldGrab] 501 } 502 # The "grab" command will fail if another application 503 # already holds the grab. So catch it. 504 catch {::grab $grab} 505 if {[winfo exists $focus]} { 506 ::focus $focus 507 } 508} 509 510# BWidget::RestoreFocusGrab -- 511# restore old focus and grab (for dialogs) 512# Arguments: 513# grab window that had taken grab 514# focus window that had taken focus 515# destroy destroy|withdraw - how to handle the old grabbed window 516# Results: 517# Returns nothing 518# 519proc BWidget::RestoreFocusGrab {grab focus {destroy destroy}} { 520 variable _focusGrab 521 set index "$grab,$focus" 522 if {[info exists _focusGrab($index)]} { 523 foreach {oldFocus oldGrab oldStatus} $_focusGrab($index) break 524 unset _focusGrab($index) 525 } else { 526 set oldGrab "" 527 } 528 529 catch {::focus $oldFocus} 530 ::grab release $grab 531 if {[string equal $destroy "withdraw"]} { 532 wm withdraw $grab 533 } else { 534 ::destroy $grab 535 } 536 if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} { 537 if {[string equal $oldStatus "global"]} { 538 ::grab -global $oldGrab 539 } else { 540 ::grab $oldGrab 541 } 542 } 543} 544 545# BWidget::badOptionString -- 546# 547# Helper function to return a proper error string when an option 548# doesn't match a list of given options. 549# 550# Arguments: 551# type A string that represents the type of option. 552# value The value that is in-valid. 553# list A list of valid options. 554# 555# Results: 556# None. 557proc BWidget::badOptionString {type value list} { 558 set last [lindex $list end] 559 set list [lreplace $list end end] 560 return "bad $type \"$value\": must be [join $list ", "], or $last" 561} 562 563 564proc BWidget::wrongNumArgsString { string } { 565 return "wrong # args: should be \"$string\"" 566} 567 568 569proc BWidget::read_file { file } { 570 set fp [open $file] 571 set x [read $fp [file size $file]] 572 close $fp 573 return $x 574} 575 576 577proc BWidget::classes { class } { 578 variable use 579 580 ${class}::use 581 set classes [list $class] 582 if {![info exists use($class)]} { return } 583 foreach class $use($class) { 584 eval lappend classes [classes $class] 585 } 586 return [lsort -unique $classes] 587} 588 589 590proc BWidget::library { args } { 591 variable use 592 593 set libs [list widget init utils] 594 set classes [list] 595 foreach class $args { 596 ${class}::use 597 eval lappend classes [classes $class] 598 } 599 600 eval lappend libs [lsort -unique $classes] 601 602 set library "" 603 foreach lib $libs { 604 if {![info exists use($lib,file)]} { 605 set file [file join $::BWIDGET::LIBRARY $lib.tcl] 606 } else { 607 set file [file join $::BWIDGET::LIBRARY $use($lib,file).tcl] 608 } 609 append library [read_file $file] 610 } 611 612 return $library 613} 614 615 616proc BWidget::inuse { class } { 617 variable ::Widget::_inuse 618 619 if {![info exists _inuse($class)]} { return 0 } 620 return [expr $_inuse($class) > 0] 621} 622 623 624proc BWidget::write { filename {mode w} } { 625 variable use 626 627 if {![info exists use(classes)]} { return } 628 629 set classes [list] 630 foreach class $use(classes) { 631 if {![inuse $class]} { continue } 632 lappend classes $class 633 } 634 635 set fp [open $filename $mode] 636 puts $fp [eval library $classes] 637 close $fp 638 639 return 640} 641 642 643# BWidget::bindMouseWheel -- 644# 645# Bind mouse wheel actions to a given widget. 646# 647# Arguments: 648# widget - The widget to bind. 649# 650# Results: 651# None. 652proc BWidget::bindMouseWheel { widget } { 653 bind $widget <MouseWheel> {%W yview scroll [expr {-%D/24}] units} 654 bind $widget <Shift-MouseWheel> {%W yview scroll [expr {-%D/120}] pages} 655 bind $widget <Control-MouseWheel> {%W yview scroll [expr {-%D/120}] units} 656 657 bind $widget <Button-4> {event generate %W <MouseWheel> -delta 120} 658 bind $widget <Button-5> {event generate %W <MouseWheel> -delta -120} 659} 660 661 662# ---------------------------------------------------------------------------- 663# widget.tcl 664# This file is part of Unifix BWidget Toolkit 665# $Id: widget.tcl,v 1.29 2005/07/28 00:40:42 hobbs Exp $ 666# ---------------------------------------------------------------------------- 667# Index of commands: 668# - Widget::tkinclude 669# - Widget::bwinclude 670# - Widget::declare 671# - Widget::addmap 672# - Widget::init 673# - Widget::destroy 674# - Widget::setoption 675# - Widget::configure 676# - Widget::cget 677# - Widget::subcget 678# - Widget::hasChanged 679# - Widget::options 680# - Widget::_get_tkwidget_options 681# - Widget::_test_tkresource 682# - Widget::_test_bwresource 683# - Widget::_test_synonym 684# - Widget::_test_string 685# - Widget::_test_flag 686# - Widget::_test_enum 687# - Widget::_test_int 688# - Widget::_test_boolean 689# ---------------------------------------------------------------------------- 690# Each megawidget gets a namespace of the same name inside the Widget namespace 691# Each of these has an array opt, which contains information about the 692# megawidget options. It maps megawidget options to a list with this format: 693# {optionType defaultValue isReadonly {additionalOptionalInfo}} 694# Option types and their additional optional info are: 695# TkResource {genericTkWidget genericTkWidgetOptionName} 696# BwResource {nothing} 697# Enum {list of enumeration values} 698# Int {Boundary information} 699# Boolean {nothing} 700# String {nothing} 701# Flag {string of valid flag characters} 702# Synonym {nothing} 703# Color {nothing} 704# 705# Next, each namespace has an array map, which maps class options to their 706# component widget options: 707# map(-foreground) => {.e -foreground .f -foreground} 708# 709# Each has an array ${path}:opt, which contains the value of each megawidget 710# option for a particular instance $path of the megawidget, and an array 711# ${path}:mod, which stores the "changed" status of configuration options. 712 713# Steps for creating a bwidget megawidget: 714# 1. parse args to extract subwidget spec 715# 2. Create frame with appropriate class and command line options 716# 3. Get initialization options from optionDB, using frame 717# 4. create subwidgets 718 719# Uses newer string operations 720package require Tcl 8.1.1 721 722namespace eval Widget { 723 variable _optiontype 724 variable _class 725 variable _tk_widget 726 727 # This controls whether we try to use themed widgets from Tile 728 variable _theme 0 729 730 variable _aqua [expr {($::tcl_version >= 8.4) && 731 [string equal [tk windowingsystem] "aqua"]}] 732 733 array set _optiontype { 734 TkResource Widget::_test_tkresource 735 BwResource Widget::_test_bwresource 736 Enum Widget::_test_enum 737 Int Widget::_test_int 738 Boolean Widget::_test_boolean 739 String Widget::_test_string 740 Flag Widget::_test_flag 741 Synonym Widget::_test_synonym 742 Color Widget::_test_color 743 Padding Widget::_test_padding 744 } 745 746 proc use {} {} 747} 748 749 750# ---------------------------------------------------------------------------- 751# Command Widget::tkinclude 752# Includes tk widget resources to BWidget widget. 753# class class name of the BWidget 754# tkwidget tk widget to include 755# subpath subpath to configure 756# args additionnal args for included options 757# ---------------------------------------------------------------------------- 758proc Widget::tkinclude { class tkwidget subpath args } { 759 foreach {cmd lopt} $args { 760 # cmd can be 761 # include options to include lopt = {opt ...} 762 # remove options to remove lopt = {opt ...} 763 # rename options to rename lopt = {opt newopt ...} 764 # prefix options to prefix lopt = {pref opt opt ..} 765 # initialize set default value for options lopt = {opt value ...} 766 # readonly set readonly flag for options lopt = {opt flag ...} 767 switch -- $cmd { 768 remove { 769 foreach option $lopt { 770 set remove($option) 1 771 } 772 } 773 include { 774 foreach option $lopt { 775 set include($option) 1 776 } 777 } 778 prefix { 779 set prefix [lindex $lopt 0] 780 foreach option [lrange $lopt 1 end] { 781 set rename($option) "-$prefix[string range $option 1 end]" 782 } 783 } 784 rename - 785 readonly - 786 initialize { 787 array set $cmd $lopt 788 } 789 default { 790 return -code error "invalid argument \"$cmd\"" 791 } 792 } 793 } 794 795 namespace eval $class {} 796 upvar 0 ${class}::opt classopt 797 upvar 0 ${class}::map classmap 798 upvar 0 ${class}::map$subpath submap 799 upvar 0 ${class}::optionExports exports 800 801 set foo [$tkwidget ".ericFoo###"] 802 # create resources informations from tk widget resources 803 foreach optdesc [_get_tkwidget_options $tkwidget] { 804 set option [lindex $optdesc 0] 805 if { (![info exists include] || [info exists include($option)]) && 806 ![info exists remove($option)] } { 807 if { [llength $optdesc] == 3 } { 808 # option is a synonym 809 set syn [lindex $optdesc 1] 810 if { ![info exists remove($syn)] } { 811 # original option is not removed 812 if { [info exists rename($syn)] } { 813 set classopt($option) [list Synonym $rename($syn)] 814 } else { 815 set classopt($option) [list Synonym $syn] 816 } 817 } 818 } else { 819 if { [info exists rename($option)] } { 820 set realopt $option 821 set option $rename($option) 822 } else { 823 set realopt $option 824 } 825 if { [info exists initialize($option)] } { 826 set value $initialize($option) 827 } else { 828 set value [lindex $optdesc 1] 829 } 830 if { [info exists readonly($option)] } { 831 set ro $readonly($option) 832 } else { 833 set ro 0 834 } 835 set classopt($option) \ 836 [list TkResource $value $ro [list $tkwidget $realopt]] 837 838 # Add an option database entry for this option 839 set optionDbName ".[lindex [_configure_option $option ""] 0]" 840 if { ![string equal $subpath ":cmd"] } { 841 set optionDbName "$subpath$optionDbName" 842 } 843 option add *${class}$optionDbName $value widgetDefault 844 lappend exports($option) "$optionDbName" 845 846 # Store the forward and backward mappings for this 847 # option <-> realoption pair 848 lappend classmap($option) $subpath "" $realopt 849 set submap($realopt) $option 850 } 851 } 852 } 853 ::destroy $foo 854} 855 856 857# ---------------------------------------------------------------------------- 858# Command Widget::bwinclude 859# Includes BWidget resources to BWidget widget. 860# class class name of the BWidget 861# subclass BWidget class to include 862# subpath subpath to configure 863# args additionnal args for included options 864# ---------------------------------------------------------------------------- 865proc Widget::bwinclude { class subclass subpath args } { 866 foreach {cmd lopt} $args { 867 # cmd can be 868 # include options to include lopt = {opt ...} 869 # remove options to remove lopt = {opt ...} 870 # rename options to rename lopt = {opt newopt ...} 871 # prefix options to prefix lopt = {prefix opt opt ...} 872 # initialize set default value for options lopt = {opt value ...} 873 # readonly set readonly flag for options lopt = {opt flag ...} 874 switch -- $cmd { 875 remove { 876 foreach option $lopt { 877 set remove($option) 1 878 } 879 } 880 include { 881 foreach option $lopt { 882 set include($option) 1 883 } 884 } 885 prefix { 886 set prefix [lindex $lopt 0] 887 foreach option [lrange $lopt 1 end] { 888 set rename($option) "-$prefix[string range $option 1 end]" 889 } 890 } 891 rename - 892 readonly - 893 initialize { 894 array set $cmd $lopt 895 } 896 default { 897 return -code error "invalid argument \"$cmd\"" 898 } 899 } 900 } 901 902 namespace eval $class {} 903 upvar 0 ${class}::opt classopt 904 upvar 0 ${class}::map classmap 905 upvar 0 ${class}::map$subpath submap 906 upvar 0 ${class}::optionExports exports 907 upvar 0 ${subclass}::opt subclassopt 908 upvar 0 ${subclass}::optionExports subexports 909 910 # create resources informations from BWidget resources 911 foreach {option optdesc} [array get subclassopt] { 912 set subOption $option 913 if { (![info exists include] || [info exists include($option)]) && 914 ![info exists remove($option)] } { 915 set type [lindex $optdesc 0] 916 if { [string equal $type "Synonym"] } { 917 # option is a synonym 918 set syn [lindex $optdesc 1] 919 if { ![info exists remove($syn)] } { 920 if { [info exists rename($syn)] } { 921 set classopt($option) [list Synonym $rename($syn)] 922 } else { 923 set classopt($option) [list Synonym $syn] 924 } 925 } 926 } else { 927 if { [info exists rename($option)] } { 928 set realopt $option 929 set option $rename($option) 930 } else { 931 set realopt $option 932 } 933 if { [info exists initialize($option)] } { 934 set value $initialize($option) 935 } else { 936 set value [lindex $optdesc 1] 937 } 938 if { [info exists readonly($option)] } { 939 set ro $readonly($option) 940 } else { 941 set ro [lindex $optdesc 2] 942 } 943 set classopt($option) \ 944 [list $type $value $ro [lindex $optdesc 3]] 945 946 # Add an option database entry for this option 947 foreach optionDbName $subexports($subOption) { 948 if { ![string equal $subpath ":cmd"] } { 949 set optionDbName "$subpath$optionDbName" 950 } 951 # Only add the option db entry if we are overriding the 952 # normal widget default 953 if { [info exists initialize($option)] } { 954 option add *${class}$optionDbName $value \ 955 widgetDefault 956 } 957 lappend exports($option) "$optionDbName" 958 } 959 960 # Store the forward and backward mappings for this 961 # option <-> realoption pair 962 lappend classmap($option) $subpath $subclass $realopt 963 set submap($realopt) $option 964 } 965 } 966 } 967} 968 969 970# ---------------------------------------------------------------------------- 971# Command Widget::declare 972# Declares new options to BWidget class. 973# ---------------------------------------------------------------------------- 974proc Widget::declare { class optlist } { 975 variable _optiontype 976 977 namespace eval $class {} 978 upvar 0 ${class}::opt classopt 979 upvar 0 ${class}::optionExports exports 980 upvar 0 ${class}::optionClass optionClass 981 982 foreach optdesc $optlist { 983 set option [lindex $optdesc 0] 984 set optdesc [lrange $optdesc 1 end] 985 set type [lindex $optdesc 0] 986 987 if { ![info exists _optiontype($type)] } { 988 # invalid resource type 989 return -code error "invalid option type \"$type\"" 990 } 991 992 if { [string equal $type "Synonym"] } { 993 # test existence of synonym option 994 set syn [lindex $optdesc 1] 995 if { ![info exists classopt($syn)] } { 996 return -code error "unknow option \"$syn\" for Synonym \"$option\"" 997 } 998 set classopt($option) [list Synonym $syn] 999 continue 1000 } 1001 1002 # all other resource may have default value, readonly flag and 1003 # optional arg depending on type 1004 set value [lindex $optdesc 1] 1005 set ro [lindex $optdesc 2] 1006 set arg [lindex $optdesc 3] 1007 1008 if { [string equal $type "BwResource"] } { 1009 # We don't keep BwResource. We simplify to type of sub BWidget 1010 set subclass [lindex $arg 0] 1011 set realopt [lindex $arg 1] 1012 if { ![string length $realopt] } { 1013 set realopt $option 1014 } 1015 1016 upvar 0 ${subclass}::opt subclassopt 1017 if { ![info exists subclassopt($realopt)] } { 1018 return -code error "unknow option \"$realopt\"" 1019 } 1020 set suboptdesc $subclassopt($realopt) 1021 if { $value == "" } { 1022 # We initialize default value 1023 set value [lindex $suboptdesc 1] 1024 } 1025 set type [lindex $suboptdesc 0] 1026 set ro [lindex $suboptdesc 2] 1027 set arg [lindex $suboptdesc 3] 1028 set optionDbName ".[lindex [_configure_option $option ""] 0]" 1029 option add *${class}${optionDbName} $value widgetDefault 1030 set exports($option) $optionDbName 1031 set classopt($option) [list $type $value $ro $arg] 1032 continue 1033 } 1034 1035 # retreive default value for TkResource 1036 if { [string equal $type "TkResource"] } { 1037 set tkwidget [lindex $arg 0] 1038 set foo [$tkwidget ".ericFoo##"] 1039 set realopt [lindex $arg 1] 1040 if { ![string length $realopt] } { 1041 set realopt $option 1042 } 1043 set tkoptions [_get_tkwidget_options $tkwidget] 1044 if { ![string length $value] } { 1045 # We initialize default value 1046 set ind [lsearch $tkoptions [list $realopt *]] 1047 set value [lindex [lindex $tkoptions $ind] end] 1048 } 1049 set optionDbName ".[lindex [_configure_option $option ""] 0]" 1050 option add *${class}${optionDbName} $value widgetDefault 1051 set exports($option) $optionDbName 1052 set classopt($option) [list TkResource $value $ro \ 1053 [list $tkwidget $realopt]] 1054 set optionClass($option) [lindex [$foo configure $realopt] 1] 1055 ::destroy $foo 1056 continue 1057 } 1058 1059 set optionDbName ".[lindex [_configure_option $option ""] 0]" 1060 option add *${class}${optionDbName} $value widgetDefault 1061 set exports($option) $optionDbName 1062 # for any other resource type, we keep original optdesc 1063 set classopt($option) [list $type $value $ro $arg] 1064 } 1065} 1066 1067 1068proc Widget::define { class filename args } { 1069 # variable ::BWidget::use 1070 set use($class) $args 1071 set use($class,file) $filename 1072 lappend use(classes) $class 1073 1074 if {[set x [lsearch -exact $args "-classonly"]] > -1} { 1075 set args [lreplace $args $x $x] 1076 } else { 1077 interp alias {} ::${class} {} ${class}::create 1078 proc ::${class}::use {} {} 1079 1080 bind $class <Destroy> [list Widget::destroy %W] 1081 } 1082 1083 foreach class $args { ${class}::use } 1084} 1085 1086 1087proc Widget::create { class path {rename 1} } { 1088 if {$rename} { rename $path ::$path:cmd } 1089 proc ::$path { cmd args } \ 1090 [subst {return \[eval \[linsert \$args 0 ${class}::\$cmd [list $path]\]\]}] 1091 return $path 1092} 1093 1094 1095# ---------------------------------------------------------------------------- 1096# Command Widget::addmap 1097# ---------------------------------------------------------------------------- 1098proc Widget::addmap { class subclass subpath options } { 1099 upvar 0 ${class}::opt classopt 1100 upvar 0 ${class}::optionExports exports 1101 upvar 0 ${class}::optionClass optionClass 1102 upvar 0 ${class}::map classmap 1103 upvar 0 ${class}::map$subpath submap 1104 1105 foreach {option realopt} $options { 1106 if { ![string length $realopt] } { 1107 set realopt $option 1108 } 1109 set val [lindex $classopt($option) 1] 1110 set optDb ".[lindex [_configure_option $realopt ""] 0]" 1111 if { ![string equal $subpath ":cmd"] } { 1112 set optDb "$subpath$optDb" 1113 } 1114 option add *${class}${optDb} $val widgetDefault 1115 lappend exports($option) $optDb 1116 # Store the forward and backward mappings for this 1117 # option <-> realoption pair 1118 lappend classmap($option) $subpath $subclass $realopt 1119 set submap($realopt) $option 1120 } 1121} 1122 1123 1124# ---------------------------------------------------------------------------- 1125# Command Widget::syncoptions 1126# ---------------------------------------------------------------------------- 1127proc Widget::syncoptions { class subclass subpath options } { 1128 upvar 0 ${class}::sync classync 1129 1130 foreach {option realopt} $options { 1131 if { ![string length $realopt] } { 1132 set realopt $option 1133 } 1134 set classync($option) [list $subpath $subclass $realopt] 1135 } 1136} 1137 1138 1139# ---------------------------------------------------------------------------- 1140# Command Widget::init 1141# ---------------------------------------------------------------------------- 1142proc Widget::init { class path options } { 1143 variable _inuse 1144 1145 upvar 0 ${class}::opt classopt 1146 upvar 0 ${class}::$path:opt pathopt 1147 upvar 0 ${class}::$path:mod pathmod 1148 upvar 0 ${class}::map classmap 1149 upvar 0 ${class}::$path:init pathinit 1150 1151 if { [info exists pathopt] } { 1152 unset pathopt 1153 } 1154 if { [info exists pathmod] } { 1155 unset pathmod 1156 } 1157 # We prefer to use the actual widget for option db queries, but if it 1158 # doesn't exist yet, do the next best thing: create a widget of the 1159 # same class and use that. 1160 set fpath $path 1161 set rdbclass [string map [list :: ""] $class] 1162 if { ![winfo exists $path] } { 1163 set fpath ".#BWidget.#Class#$class" 1164 # encapsulation frame to not pollute '.' childspace 1165 if {![winfo exists ".#BWidget"]} { frame ".#BWidget" } 1166 if { ![winfo exists $fpath] } { 1167 frame $fpath -class $rdbclass 1168 } 1169 } 1170 foreach {option optdesc} [array get classopt] { 1171 set pathmod($option) 0 1172 if { [info exists classmap($option)] } { 1173 continue 1174 } 1175 set type [lindex $optdesc 0] 1176 if { [string equal $type "Synonym"] } { 1177 continue 1178 } 1179 if { [string equal $type "TkResource"] } { 1180 set alt [lindex [lindex $optdesc 3] 1] 1181 } else { 1182 set alt "" 1183 } 1184 set optdb [lindex [_configure_option $option $alt] 0] 1185 set def [option get $fpath $optdb $rdbclass] 1186 if { [string length $def] } { 1187 set pathopt($option) $def 1188 } else { 1189 set pathopt($option) [lindex $optdesc 1] 1190 } 1191 } 1192 1193 if {![info exists _inuse($class)]} { set _inuse($class) 0 } 1194 incr _inuse($class) 1195 1196 set Widget::_class($path) $class 1197 foreach {option value} $options { 1198 if { ![info exists classopt($option)] } { 1199 unset pathopt 1200 unset pathmod 1201 return -code error "unknown option \"$option\"" 1202 } 1203 set optdesc $classopt($option) 1204 set type [lindex $optdesc 0] 1205 if { [string equal $type "Synonym"] } { 1206 set option [lindex $optdesc 1] 1207 set optdesc $classopt($option) 1208 set type [lindex $optdesc 0] 1209 } 1210 set pathopt($option) [$Widget::_optiontype($type) $option $value [lindex $optdesc 3]] 1211 set pathinit($option) $pathopt($option) 1212 } 1213} 1214 1215# Bastien Chevreux (bach@mwgdna.com) 1216# 1217# copyinit performs basically the same job as init, but it uses a 1218# existing template to initialize its values. So, first a perferct copy 1219# from the template is made just to be altered by any existing options 1220# afterwards. 1221# But this still saves time as the first initialization parsing block is 1222# skipped. 1223# As additional bonus, items that differ in just a few options can be 1224# initialized faster by leaving out the options that are equal. 1225 1226# This function is currently used only by ListBox::multipleinsert, but other 1227# calls should follow :) 1228 1229# ---------------------------------------------------------------------------- 1230# Command Widget::copyinit 1231# ---------------------------------------------------------------------------- 1232proc Widget::copyinit { class templatepath path options } { 1233 upvar 0 ${class}::opt classopt \ 1234 ${class}::$path:opt pathopt \ 1235 ${class}::$path:mod pathmod \ 1236 ${class}::$path:init pathinit \ 1237 ${class}::$templatepath:opt templatepathopt \ 1238 ${class}::$templatepath:mod templatepathmod \ 1239 ${class}::$templatepath:init templatepathinit 1240 1241 if { [info exists pathopt] } { 1242 unset pathopt 1243 } 1244 if { [info exists pathmod] } { 1245 unset pathmod 1246 } 1247 1248 # We use the template widget for option db copying, but it has to exist! 1249 array set pathmod [array get templatepathmod] 1250 array set pathopt [array get templatepathopt] 1251 array set pathinit [array get templatepathinit] 1252 1253 set Widget::_class($path) $class 1254 foreach {option value} $options { 1255 if { ![info exists classopt($option)] } { 1256 unset pathopt 1257 unset pathmod 1258 return -code error "unknown option \"$option\"" 1259 } 1260 set optdesc $classopt($option) 1261 set type [lindex $optdesc 0] 1262 if { [string equal $type "Synonym"] } { 1263 set option [lindex $optdesc 1] 1264 set optdesc $classopt($option) 1265 set type [lindex $optdesc 0] 1266 } 1267 set pathopt($option) [$Widget::_optiontype($type) $option $value [lindex $optdesc 3]] 1268 set pathinit($option) $pathopt($option) 1269 } 1270} 1271 1272# Widget::parseArgs -- 1273# 1274# Given a widget class and a command-line spec, cannonize and validate 1275# the given options, and return a keyed list consisting of the 1276# component widget and its masked portion of the command-line spec, and 1277# one extra entry consisting of the portion corresponding to the 1278# megawidget itself. 1279# 1280# Arguments: 1281# class widget class to parse for. 1282# options command-line spec 1283# 1284# Results: 1285# result keyed list of portions of the megawidget and that segment of 1286# the command line in which that portion is interested. 1287 1288proc Widget::parseArgs {class options} { 1289 upvar 0 ${class}::opt classopt 1290 upvar 0 ${class}::map classmap 1291 1292 foreach {option val} $options { 1293 if { ![info exists classopt($option)] } { 1294 error "unknown option \"$option\"" 1295 } 1296 set optdesc $classopt($option) 1297 set type [lindex $optdesc 0] 1298 if { [string equal $type "Synonym"] } { 1299 set option [lindex $optdesc 1] 1300 set optdesc $classopt($option) 1301 set type [lindex $optdesc 0] 1302 } 1303 if { [string equal $type "TkResource"] } { 1304 # Make sure that the widget used for this TkResource exists 1305 Widget::_get_tkwidget_options [lindex [lindex $optdesc 3] 0] 1306 } 1307 set val [$Widget::_optiontype($type) $option $val [lindex $optdesc 3]] 1308 1309 if { [info exists classmap($option)] } { 1310 foreach {subpath subclass realopt} $classmap($option) { 1311 lappend maps($subpath) $realopt $val 1312 } 1313 } else { 1314 lappend maps($class) $option $val 1315 } 1316 } 1317 return [array get maps] 1318} 1319 1320# Widget::initFromODB -- 1321# 1322# Initialize a megawidgets options with information from the option 1323# database and from the command-line arguments given. 1324# 1325# Arguments: 1326# class class of the widget. 1327# path path of the widget -- should already exist. 1328# options command-line arguments. 1329# 1330# Results: 1331# None. 1332 1333proc Widget::initFromODB {class path options} { 1334 variable _inuse 1335 variable _class 1336 1337 upvar 0 ${class}::$path:opt pathopt 1338 upvar 0 ${class}::$path:mod pathmod 1339 upvar 0 ${class}::map classmap 1340 1341 if { [info exists pathopt] } { 1342 unset pathopt 1343 } 1344 if { [info exists pathmod] } { 1345 unset pathmod 1346 } 1347 # We prefer to use the actual widget for option db queries, but if it 1348 # doesn't exist yet, do the next best thing: create a widget of the 1349 # same class and use that. 1350 set fpath [_get_window $class $path] 1351 set rdbclass [string map [list :: ""] $class] 1352 if { ![winfo exists $path] } { 1353 set fpath ".#BWidget.#Class#$class" 1354 # encapsulation frame to not pollute '.' childspace 1355 if {![winfo exists ".#BWidget"]} { frame ".#BWidget" } 1356 if { ![winfo exists $fpath] } { 1357 frame $fpath -class $rdbclass 1358 } 1359 } 1360 1361 foreach {option optdesc} [array get ${class}::opt] { 1362 set pathmod($option) 0 1363 if { [info exists classmap($option)] } { 1364 continue 1365 } 1366 set type [lindex $optdesc 0] 1367 if { [string equal $type "Synonym"] } { 1368 continue 1369 } 1370 if { [string equal $type "TkResource"] } { 1371 set alt [lindex [lindex $optdesc 3] 1] 1372 } else { 1373 set alt "" 1374 } 1375 set optdb [lindex [_configure_option $option $alt] 0] 1376 set def [option get $fpath $optdb $rdbclass] 1377 if { [string length $def] } { 1378 set pathopt($option) $def 1379 } else { 1380 set pathopt($option) [lindex $optdesc 1] 1381 } 1382 } 1383 1384 if {![info exists _inuse($class)]} { set _inuse($class) 0 } 1385 incr _inuse($class) 1386 1387 set _class($path) $class 1388 array set pathopt $options 1389} 1390 1391 1392 1393# ---------------------------------------------------------------------------- 1394# Command Widget::destroy 1395# ---------------------------------------------------------------------------- 1396proc Widget::destroy { path } { 1397 variable _class 1398 variable _inuse 1399 1400 if {![info exists _class($path)]} { return } 1401 1402 set class $_class($path) 1403 upvar 0 ${class}::$path:opt pathopt 1404 upvar 0 ${class}::$path:mod pathmod 1405 upvar 0 ${class}::$path:init pathinit 1406 1407 if {[info exists _inuse($class)]} { incr _inuse($class) -1 } 1408 1409 if {[info exists pathopt]} { 1410 unset pathopt 1411 } 1412 if {[info exists pathmod]} { 1413 unset pathmod 1414 } 1415 if {[info exists pathinit]} { 1416 unset pathinit 1417 } 1418 1419 if {![string equal [info commands $path] ""]} { rename $path "" } 1420 1421 ## Unset any variables used in this widget. 1422 foreach var [info vars ::${class}::$path:*] { unset $var } 1423 1424 unset _class($path) 1425} 1426 1427 1428# ---------------------------------------------------------------------------- 1429# Command Widget::configure 1430# ---------------------------------------------------------------------------- 1431proc Widget::configure { path options } { 1432 set len [llength $options] 1433 if { $len <= 1 } { 1434 return [_get_configure $path $options] 1435 } elseif { $len % 2 == 1 } { 1436 return -code error "incorrect number of arguments" 1437 } 1438 1439 variable _class 1440 variable _optiontype 1441 1442 set class $_class($path) 1443 upvar 0 ${class}::opt classopt 1444 upvar 0 ${class}::map classmap 1445 upvar 0 ${class}::$path:opt pathopt 1446 upvar 0 ${class}::$path:mod pathmod 1447 1448 set window [_get_window $class $path] 1449 foreach {option value} $options { 1450 if { ![info exists classopt($option)] } { 1451 return -code error "unknown option \"$option\"" 1452 } 1453 set optdesc $classopt($option) 1454 set type [lindex $optdesc 0] 1455 if { [string equal $type "Synonym"] } { 1456 set option [lindex $optdesc 1] 1457 set optdesc $classopt($option) 1458 set type [lindex $optdesc 0] 1459 } 1460 if { ![lindex $optdesc 2] } { 1461 set newval [$_optiontype($type) $option $value [lindex $optdesc 3]] 1462 if { [info exists classmap($option)] } { 1463 set window [_get_window $class $window] 1464 foreach {subpath subclass realopt} $classmap($option) { 1465 if { [string length $subclass] } { 1466 set curval [${subclass}::cget $window$subpath $realopt] 1467 ${subclass}::configure $window$subpath $realopt $newval 1468 } else { 1469 set curval [$window$subpath cget $realopt] 1470 $window$subpath configure $realopt $newval 1471 } 1472 } 1473 } else { 1474 set curval $pathopt($option) 1475 set pathopt($option) $newval 1476 } 1477 set pathmod($option) [expr {![string equal $newval $curval]}] 1478 } 1479 } 1480 1481 return {} 1482} 1483 1484 1485# ---------------------------------------------------------------------------- 1486# Command Widget::cget 1487# ---------------------------------------------------------------------------- 1488proc Widget::cget { path option } { 1489 if { ![info exists ::Widget::_class($path)] } { 1490 return -code error "unknown widget $path" 1491 } 1492 1493 set class $::Widget::_class($path) 1494 if { ![info exists ${class}::opt($option)] } { 1495 return -code error "unknown option \"$option\"" 1496 } 1497 1498 set optdesc [set ${class}::opt($option)] 1499 set type [lindex $optdesc 0] 1500 if {[string equal $type "Synonym"]} { 1501 set option [lindex $optdesc 1] 1502 } 1503 1504 if { [info exists ${class}::map($option)] } { 1505 foreach {subpath subclass realopt} [set ${class}::map($option)] {break} 1506 set path "[_get_window $class $path]$subpath" 1507 return [$path cget $realopt] 1508 } 1509 upvar 0 ${class}::$path:opt pathopt 1510 set pathopt($option) 1511} 1512 1513 1514# ---------------------------------------------------------------------------- 1515# Command Widget::subcget 1516# ---------------------------------------------------------------------------- 1517proc Widget::subcget { path subwidget } { 1518 set class $::Widget::_class($path) 1519 upvar 0 ${class}::$path:opt pathopt 1520 upvar 0 ${class}::map$subwidget submap 1521 upvar 0 ${class}::$path:init pathinit 1522 1523 set result {} 1524 foreach realopt [array names submap] { 1525 if { [info exists pathinit($submap($realopt))] } { 1526 lappend result $realopt $pathopt($submap($realopt)) 1527 } 1528 } 1529 return $result 1530} 1531 1532 1533# ---------------------------------------------------------------------------- 1534# Command Widget::hasChanged 1535# ---------------------------------------------------------------------------- 1536proc Widget::hasChanged { path option pvalue } { 1537 upvar $pvalue value 1538 set class $::Widget::_class($path) 1539 upvar 0 ${class}::$path:mod pathmod 1540 1541 set value [Widget::cget $path $option] 1542 set result $pathmod($option) 1543 set pathmod($option) 0 1544 1545 return $result 1546} 1547 1548proc Widget::hasChangedX { path option args } { 1549 set class $::Widget::_class($path) 1550 upvar 0 ${class}::$path:mod pathmod 1551 1552 set result $pathmod($option) 1553 set pathmod($option) 0 1554 foreach option $args { 1555 lappend result $pathmod($option) 1556 set pathmod($option) 0 1557 } 1558 1559 set result 1560} 1561 1562 1563# ---------------------------------------------------------------------------- 1564# Command Widget::setoption 1565# ---------------------------------------------------------------------------- 1566proc Widget::setoption { path option value } { 1567# variable _class 1568 1569# set class $_class($path) 1570# upvar 0 ${class}::$path:opt pathopt 1571 1572# set pathopt($option) $value 1573 Widget::configure $path [list $option $value] 1574} 1575 1576 1577# ---------------------------------------------------------------------------- 1578# Command Widget::getoption 1579# ---------------------------------------------------------------------------- 1580proc Widget::getoption { path option } { 1581# set class $::Widget::_class($path) 1582# upvar 0 ${class}::$path:opt pathopt 1583 1584# return $pathopt($option) 1585 return [Widget::cget $path $option] 1586} 1587 1588# Widget::getMegawidgetOption -- 1589# 1590# Bypass the superfluous checks in cget and just directly peer at the 1591# widget's data space. This is much more fragile than cget, so it 1592# should only be used with great care, in places where speed is critical. 1593# 1594# Arguments: 1595# path widget to lookup options for. 1596# option option to retrieve. 1597# 1598# Results: 1599# value option value. 1600 1601proc Widget::getMegawidgetOption {path option} { 1602 set class $::Widget::_class($path) 1603 upvar 0 ${class}::${path}:opt pathopt 1604 set pathopt($option) 1605} 1606 1607# Widget::setMegawidgetOption -- 1608# 1609# Bypass the superfluous checks in cget and just directly poke at the 1610# widget's data space. This is much more fragile than configure, so it 1611# should only be used with great care, in places where speed is critical. 1612# 1613# Arguments: 1614# path widget to lookup options for. 1615# option option to retrieve. 1616# value option value. 1617# 1618# Results: 1619# value option value. 1620 1621proc Widget::setMegawidgetOption {path option value} { 1622 set class $::Widget::_class($path) 1623 upvar 0 ${class}::${path}:opt pathopt 1624 set pathopt($option) $value 1625} 1626 1627# ---------------------------------------------------------------------------- 1628# Command Widget::_get_window 1629# returns the window corresponding to widget path 1630# ---------------------------------------------------------------------------- 1631proc Widget::_get_window { class path } { 1632 set idx [string last "#" $path] 1633 if { $idx != -1 && [string equal [string range $path [expr {$idx+1}] end] $class] } { 1634 return [string range $path 0 [expr {$idx-1}]] 1635 } else { 1636 return $path 1637 } 1638} 1639 1640 1641# ---------------------------------------------------------------------------- 1642# Command Widget::_get_configure 1643# returns the configuration list of options 1644# (as tk widget do - [$w configure ?option?]) 1645# ---------------------------------------------------------------------------- 1646proc Widget::_get_configure { path options } { 1647 variable _class 1648 1649 set class $_class($path) 1650 upvar 0 ${class}::opt classopt 1651 upvar 0 ${class}::map classmap 1652 upvar 0 ${class}::$path:opt pathopt 1653 upvar 0 ${class}::$path:mod pathmod 1654 1655 set len [llength $options] 1656 if { !$len } { 1657 set result {} 1658 foreach option [lsort [array names classopt]] { 1659 set optdesc $classopt($option) 1660 set type [lindex $optdesc 0] 1661 if { [string equal $type "Synonym"] } { 1662 set syn $option 1663 set option [lindex $optdesc 1] 1664 set optdesc $classopt($option) 1665 set type [lindex $optdesc 0] 1666 } else { 1667 set syn "" 1668 } 1669 if { [string equal $type "TkResource"] } { 1670 set alt [lindex [lindex $optdesc 3] 1] 1671 } else { 1672 set alt "" 1673 } 1674 set res [_configure_option $option $alt] 1675 if { $syn == "" } { 1676 lappend result [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]] 1677 } else { 1678 lappend result [list $syn [lindex $res 0]] 1679 } 1680 } 1681 return $result 1682 } elseif { $len == 1 } { 1683 set option [lindex $options 0] 1684 if { ![info exists classopt($option)] } { 1685 return -code error "unknown option \"$option\"" 1686 } 1687 set optdesc $classopt($option) 1688 set type [lindex $optdesc 0] 1689 if { [string equal $type "Synonym"] } { 1690 set option [lindex $optdesc 1] 1691 set optdesc $classopt($option) 1692 set type [lindex $optdesc 0] 1693 } 1694 if { [string equal $type "TkResource"] } { 1695 set alt [lindex [lindex $optdesc 3] 1] 1696 } else { 1697 set alt "" 1698 } 1699 set res [_configure_option $option $alt] 1700 return [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]] 1701 } 1702} 1703 1704 1705# ---------------------------------------------------------------------------- 1706# Command Widget::_configure_option 1707# ---------------------------------------------------------------------------- 1708proc Widget::_configure_option { option altopt } { 1709 variable _optiondb 1710 variable _optionclass 1711 1712 if { [info exists _optiondb($option)] } { 1713 set optdb $_optiondb($option) 1714 } else { 1715 set optdb [string range $option 1 end] 1716 } 1717 if { [info exists _optionclass($option)] } { 1718 set optclass $_optionclass($option) 1719 } elseif { [string length $altopt] } { 1720 if { [info exists _optionclass($altopt)] } { 1721 set optclass $_optionclass($altopt) 1722 } else { 1723 set optclass [string range $altopt 1 end] 1724 } 1725 } else { 1726 set optclass [string range $option 1 end] 1727 } 1728 return [list $optdb $optclass] 1729} 1730 1731 1732# ---------------------------------------------------------------------------- 1733# Command Widget::_get_tkwidget_options 1734# ---------------------------------------------------------------------------- 1735proc Widget::_get_tkwidget_options { tkwidget } { 1736 variable _tk_widget 1737 variable _optiondb 1738 variable _optionclass 1739 1740 set widget ".#BWidget.#$tkwidget" 1741 # encapsulation frame to not pollute '.' childspace 1742 if {![winfo exists ".#BWidget"]} { frame ".#BWidget" } 1743 if { ![winfo exists $widget] || ![info exists _tk_widget($tkwidget)] } { 1744 set widget [$tkwidget $widget] 1745 # JDC: Withdraw toplevels, otherwise visible 1746 if {[string equal $tkwidget "toplevel"]} { 1747 wm withdraw $widget 1748 } 1749 set config [$widget configure] 1750 foreach optlist $config { 1751 set opt [lindex $optlist 0] 1752 if { [llength $optlist] == 2 } { 1753 set refsyn [lindex $optlist 1] 1754 # search for class 1755 set idx [lsearch $config [list * $refsyn *]] 1756 if { $idx == -1 } { 1757 if { [string index $refsyn 0] == "-" } { 1758 # search for option (tk8.1b1 bug) 1759 set idx [lsearch $config [list $refsyn * *]] 1760 } else { 1761 # last resort 1762 set idx [lsearch $config [list -[string tolower $refsyn] * *]] 1763 } 1764 if { $idx == -1 } { 1765 # fed up with "can't read classopt()" 1766 return -code error "can't find option of synonym $opt" 1767 } 1768 } 1769 set syn [lindex [lindex $config $idx] 0] 1770 # JDC: used 4 (was 3) to get def from optiondb 1771 set def [lindex [lindex $config $idx] 4] 1772 lappend _tk_widget($tkwidget) [list $opt $syn $def] 1773 } else { 1774 # JDC: used 4 (was 3) to get def from optiondb 1775 set def [lindex $optlist 4] 1776 lappend _tk_widget($tkwidget) [list $opt $def] 1777 set _optiondb($opt) [lindex $optlist 1] 1778 set _optionclass($opt) [lindex $optlist 2] 1779 } 1780 } 1781 } 1782 return $_tk_widget($tkwidget) 1783} 1784 1785 1786# ---------------------------------------------------------------------------- 1787# Command Widget::_test_tkresource 1788# ---------------------------------------------------------------------------- 1789proc Widget::_test_tkresource { option value arg } { 1790# set tkwidget [lindex $arg 0] 1791# set realopt [lindex $arg 1] 1792 foreach {tkwidget realopt} $arg break 1793 set path ".#BWidget.#$tkwidget" 1794 set old [$path cget $realopt] 1795 $path configure $realopt $value 1796 set res [$path cget $realopt] 1797 $path configure $realopt $old 1798 1799 return $res 1800} 1801 1802 1803# ---------------------------------------------------------------------------- 1804# Command Widget::_test_bwresource 1805# ---------------------------------------------------------------------------- 1806proc Widget::_test_bwresource { option value arg } { 1807 return -code error "bad option type BwResource in widget" 1808} 1809 1810 1811# ---------------------------------------------------------------------------- 1812# Command Widget::_test_synonym 1813# ---------------------------------------------------------------------------- 1814proc Widget::_test_synonym { option value arg } { 1815 return -code error "bad option type Synonym in widget" 1816} 1817 1818# ---------------------------------------------------------------------------- 1819# Command Widget::_test_color 1820# ---------------------------------------------------------------------------- 1821proc Widget::_test_color { option value arg } { 1822 if {[catch {winfo rgb . $value} color]} { 1823 return -code error "bad $option value \"$value\": must be a colorname \ 1824 or #RRGGBB triplet" 1825 } 1826 1827 return $value 1828} 1829 1830 1831# ---------------------------------------------------------------------------- 1832# Command Widget::_test_string 1833# ---------------------------------------------------------------------------- 1834proc Widget::_test_string { option value arg } { 1835 set value 1836} 1837 1838 1839# ---------------------------------------------------------------------------- 1840# Command Widget::_test_flag 1841# ---------------------------------------------------------------------------- 1842proc Widget::_test_flag { option value arg } { 1843 set len [string length $value] 1844 set res "" 1845 for {set i 0} {$i < $len} {incr i} { 1846 set c [string index $value $i] 1847 if { [string first $c $arg] == -1 } { 1848 return -code error "bad [string range $option 1 end] value \"$value\": characters must be in \"$arg\"" 1849 } 1850 if { [string first $c $res] == -1 } { 1851 append res $c 1852 } 1853 } 1854 return $res 1855} 1856 1857 1858# ----------------------------------------------------------------------------- 1859# Command Widget::_test_enum 1860# ----------------------------------------------------------------------------- 1861proc Widget::_test_enum { option value arg } { 1862 if { [lsearch $arg $value] == -1 } { 1863 set last [lindex $arg end] 1864 set sub [lreplace $arg end end] 1865 if { [llength $sub] } { 1866 set str "[join $sub ", "] or $last" 1867 } else { 1868 set str $last 1869 } 1870 return -code error "bad [string range $option 1 end] value \"$value\": must be $str" 1871 } 1872 return $value 1873} 1874 1875 1876# ----------------------------------------------------------------------------- 1877# Command Widget::_test_int 1878# ----------------------------------------------------------------------------- 1879proc Widget::_test_int { option value arg } { 1880 if { ![string is int -strict $value] || \ 1881 ([string length $arg] && \ 1882 ![expr [string map [list %d $value] $arg]]) } { 1883 return -code error "bad $option value\ 1884 \"$value\": must be integer ($arg)" 1885 } 1886 return $value 1887} 1888 1889 1890# ----------------------------------------------------------------------------- 1891# Command Widget::_test_boolean 1892# ----------------------------------------------------------------------------- 1893proc Widget::_test_boolean { option value arg } { 1894 if { ![string is boolean -strict $value] } { 1895 return -code error "bad $option value \"$value\": must be boolean" 1896 } 1897 1898 # Get the canonical form of the boolean value (1 for true, 0 for false) 1899 return [string is true $value] 1900} 1901 1902 1903# ----------------------------------------------------------------------------- 1904# Command Widget::_test_padding 1905# ----------------------------------------------------------------------------- 1906proc Widget::_test_padding { option values arg } { 1907 set len [llength $values] 1908 if {$len < 1 || $len > 2} { 1909 return -code error "bad pad value \"$values\":\ 1910 must be positive screen distance" 1911 } 1912 1913 foreach value $values { 1914 if { ![string is int -strict $value] || \ 1915 ([string length $arg] && \ 1916 ![expr [string map [list %d $value] $arg]]) } { 1917 return -code error "bad pad value \"$value\":\ 1918 must be positive screen distance ($arg)" 1919 } 1920 } 1921 return $values 1922} 1923 1924 1925# Widget::_get_padding -- 1926# 1927# Return the requesting padding value for a padding option. 1928# 1929# Arguments: 1930# path Widget to get the options for. 1931# option The name of the padding option. 1932# index The index of the padding. If the index is empty, 1933# the first padding value is returned. 1934# 1935# Results: 1936# Return a numeric value that can be used for padding. 1937proc Widget::_get_padding { path option {index 0} } { 1938 set pad [Widget::cget $path $option] 1939 set val [lindex $pad $index] 1940 if {$val == ""} { set val [lindex $pad 0] } 1941 return $val 1942} 1943 1944 1945# ----------------------------------------------------------------------------- 1946# Command Widget::focusNext 1947# Same as tk_focusNext, but call Widget::focusOK 1948# ----------------------------------------------------------------------------- 1949proc Widget::focusNext { w } { 1950 set cur $w 1951 while 1 { 1952 1953 # Descend to just before the first child of the current widget. 1954 1955 set parent $cur 1956 set children [winfo children $cur] 1957 set i -1 1958 1959 # Look for the next sibling that isn't a top-level. 1960 1961 while 1 { 1962 incr i 1963 if {$i < [llength $children]} { 1964 set cur [lindex $children $i] 1965 if {[string equal [winfo toplevel $cur] $cur]} { 1966 continue 1967 } else { 1968 break 1969 } 1970 } 1971 1972 # No more siblings, so go to the current widget's parent. 1973 # If it's a top-level, break out of the loop, otherwise 1974 # look for its next sibling. 1975 1976 set cur $parent 1977 if {[string equal [winfo toplevel $cur] $cur]} { 1978 break 1979 } 1980 set parent [winfo parent $parent] 1981 set children [winfo children $parent] 1982 set i [lsearch -exact $children $cur] 1983 } 1984 if {[string equal $cur $w] || [focusOK $cur]} { 1985 return $cur 1986 } 1987 } 1988} 1989 1990 1991# ----------------------------------------------------------------------------- 1992# Command Widget::focusPrev 1993# Same as tk_focusPrev, except: 1994# + Don't traverse from a child to a direct ancestor 1995# + Call Widget::focusOK instead of tk::focusOK 1996# ----------------------------------------------------------------------------- 1997proc Widget::focusPrev { w } { 1998 set cur $w 1999 set origParent [winfo parent $w] 2000 while 1 { 2001 2002 # Collect information about the current window's position 2003 # among its siblings. Also, if the window is a top-level, 2004 # then reposition to just after the last child of the window. 2005 2006 if {[string equal [winfo toplevel $cur] $cur]} { 2007 set parent $cur 2008 set children [winfo children $cur] 2009 set i [llength $children] 2010 } else { 2011 set parent [winfo parent $cur] 2012 set children [winfo children $parent] 2013 set i [lsearch -exact $children $cur] 2014 } 2015 2016 # Go to the previous sibling, then descend to its last descendant 2017 # (highest in stacking order. While doing this, ignore top-levels 2018 # and their descendants. When we run out of descendants, go up 2019 # one level to the parent. 2020 2021 while {$i > 0} { 2022 incr i -1 2023 set cur [lindex $children $i] 2024 if {[string equal [winfo toplevel $cur] $cur]} { 2025 continue 2026 } 2027 set parent $cur 2028 set children [winfo children $parent] 2029 set i [llength $children] 2030 } 2031 set cur $parent 2032 if {[string equal $cur $w]} { 2033 return $cur 2034 } 2035 # If we are just at the original parent of $w, skip it as a 2036 # potential focus accepter. Extra safety in this is to see if 2037 # that parent is also a proc (not a C command), which is what 2038 # BWidgets makes for any megawidget. Could possibly also check 2039 # for '[info commands ::${origParent}:cmd] != ""'. [Bug 765667] 2040 if {[string equal $cur $origParent] 2041 && [info procs ::$origParent] != ""} { 2042 continue 2043 } 2044 if {[focusOK $cur]} { 2045 return $cur 2046 } 2047 } 2048} 2049 2050 2051# ---------------------------------------------------------------------------- 2052# Command Widget::focusOK 2053# Same as tk_focusOK, but handles -editable option and whole tags list. 2054# ---------------------------------------------------------------------------- 2055proc Widget::focusOK { w } { 2056 set code [catch {$w cget -takefocus} value] 2057 if { $code == 1 } { 2058 return 0 2059 } 2060 if {($code == 0) && ($value != "")} { 2061 if {$value == 0} { 2062 return 0 2063 } elseif {$value == 1} { 2064 return [winfo viewable $w] 2065 } else { 2066 set value [uplevel \#0 $value $w] 2067 if {$value != ""} { 2068 return $value 2069 } 2070 } 2071 } 2072 if {![winfo viewable $w]} { 2073 return 0 2074 } 2075 set code [catch {$w cget -state} value] 2076 if {($code == 0) && ($value == "disabled")} { 2077 return 0 2078 } 2079 set code [catch {$w cget -editable} value] 2080 if {($code == 0) && ($value == 0)} { 2081 return 0 2082 } 2083 2084 set top [winfo toplevel $w] 2085 foreach tags [bindtags $w] { 2086 if { ![string equal $tags $top] && 2087 ![string equal $tags "all"] && 2088 [regexp Key [bind $tags]] } { 2089 return 1 2090 } 2091 } 2092 return 0 2093} 2094 2095 2096proc Widget::traverseTo { w } { 2097 set focus [focus] 2098 if {![string equal $focus ""]} { 2099 event generate $focus <<TraverseOut>> 2100 } 2101 focus $w 2102 2103 event generate $w <<TraverseIn>> 2104} 2105 2106 2107# Widget::varForOption -- 2108# 2109# Retrieve a fully qualified variable name for the option specified. 2110# If the option is not one for which a variable exists, throw an error 2111# (ie, those options that map directly to widget options). 2112# 2113# Arguments: 2114# path megawidget to get an option var for. 2115# option option to get a var for. 2116# 2117# Results: 2118# varname name of the variable, fully qualified, suitable for tracing. 2119 2120proc Widget::varForOption {path option} { 2121 variable _class 2122 variable _optiontype 2123 2124 set class $_class($path) 2125 upvar 0 ${class}::$path:opt pathopt 2126 2127 if { ![info exists pathopt($option)] } { 2128 error "unable to find variable for option \"$option\"" 2129 } 2130 set varname "::Widget::${class}::$path:opt($option)" 2131 return $varname 2132} 2133 2134# Widget::getVariable -- 2135# 2136# Get a variable from within the namespace of the widget. 2137# 2138# Arguments: 2139# path Megawidget to get the variable for. 2140# varName The variable name to retrieve. 2141# newVarName The variable name to refer to in the calling proc. 2142# 2143# Results: 2144# Creates a reference to newVarName in the calling proc. 2145proc Widget::getVariable { path varName {newVarName ""} } { 2146 variable _class 2147 set class $_class($path) 2148 if {![string length $newVarName]} { set newVarName $varName } 2149 uplevel 1 [list upvar \#0 ${class}::$path:$varName $newVarName] 2150} 2151 2152# Widget::options -- 2153# 2154# Return a key-value list of options for a widget. This can 2155# be used to serialize the options of a widget and pass them 2156# on to a new widget with the same options. 2157# 2158# Arguments: 2159# path Widget to get the options for. 2160# args A list of options. If empty, all options are returned. 2161# 2162# Results: 2163# Returns list of options as: -option value -option value ... 2164proc Widget::options { path args } { 2165 if {[llength $args]} { 2166 foreach option $args { 2167 lappend options [_get_configure $path $option] 2168 } 2169 } else { 2170 set options [_get_configure $path {}] 2171 } 2172 2173 set result [list] 2174 foreach list $options { 2175 if {[llength $list] < 5} { continue } 2176 lappend result [lindex $list 0] [lindex $list end] 2177 } 2178 return $result 2179} 2180 2181 2182# Widget::getOption -- 2183# 2184# Given a list of widgets, determine which option value to use. 2185# The widgets are given to the command in order of highest to 2186# lowest. Starting with the lowest widget, whichever one does 2187# not match the default option value is returned as the value. 2188# If all the widgets are default, we return the highest widget's 2189# value. 2190# 2191# Arguments: 2192# option The option to check. 2193# default The default value. If any widget in the list 2194# does not match this default, its value is used. 2195# args A list of widgets. 2196# 2197# Results: 2198# Returns the value of the given option to use. 2199# 2200proc Widget::getOption { option default args } { 2201 for {set i [expr [llength $args] -1]} {$i >= 0} {incr i -1} { 2202 set widget [lindex $args $i] 2203 set value [Widget::cget $widget $option] 2204 if {[string equal $value $default]} { continue } 2205 return $value 2206 } 2207 return $value 2208} 2209 2210 2211proc Widget::nextIndex { path node } { 2212 Widget::getVariable $path autoIndex 2213 if {![info exists autoIndex]} { set autoIndex -1 } 2214 return [string map [list #auto [incr autoIndex]] $node] 2215} 2216 2217 2218proc Widget::exists { path } { 2219 variable _class 2220 return [info exists _class($path)] 2221} 2222 2223proc Widget::theme {{bool {}}} { 2224 # Private, *experimental* API that may change at any time - JH 2225 variable _theme 2226 if {[llength [info level 0]] == 2} { 2227 # set theme-ability 2228 if {[catch {package require tile 0.6}] 2229 && [catch {package require tile 1}]} { 2230 return -code error "BWidget's theming requires tile 0.6+" 2231 } else { 2232 catch {style default BWSlim.Toolbutton -padding 0} 2233 } 2234 set _theme [string is true -strict $bool] 2235 } 2236 return $_theme 2237} 2238 2239 2240namespace eval ProgressBar { 2241 Widget::define ProgressBar progressbar 2242 2243 Widget::declare ProgressBar { 2244 {-type Enum normal 0 2245 {normal incremental infinite nonincremental_infinite}} 2246 {-maximum Int 100 0 "%d > 0"} 2247 {-background TkResource "" 0 frame} 2248 {-foreground TkResource "blue" 0 label} 2249 {-borderwidth TkResource 2 0 frame} 2250 {-troughcolor TkResource "" 0 scrollbar} 2251 {-relief TkResource sunken 0 label} 2252 {-orient Enum horizontal 1 {horizontal vertical}} 2253 {-variable String "" 0} 2254 {-idle Boolean 0 0} 2255 {-width TkResource 100 0 frame} 2256 {-height TkResource 4m 0 frame} 2257 {-bg Synonym -background} 2258 {-fg Synonym -foreground} 2259 {-bd Synonym -borderwidth} 2260 } 2261 2262 Widget::addmap ProgressBar "" :cmd {-background {} -width {} -height {}} 2263 Widget::addmap ProgressBar "" .bar { 2264 -troughcolor -background -borderwidth {} -relief {} 2265 } 2266 2267 variable _widget 2268} 2269 2270 2271# ---------------------------------------------------------------------------- 2272# Command ProgressBar::create 2273# ---------------------------------------------------------------------------- 2274proc ProgressBar::create { path args } { 2275 variable _widget 2276 2277 array set maps [list ProgressBar {} :cmd {} .bar {}] 2278 array set maps [Widget::parseArgs ProgressBar $args] 2279 eval frame $path $maps(:cmd) -class ProgressBar -bd 0 \ 2280 -highlightthickness 0 -relief flat 2281 Widget::initFromODB ProgressBar $path $maps(ProgressBar) 2282 2283 set c [eval [list canvas $path.bar] $maps(.bar) -highlightthickness 0] 2284 set fg [Widget::cget $path -foreground] 2285 if { [string equal [Widget::cget $path -orient] "horizontal"] } { 2286 $path.bar create rectangle -1 0 0 0 -fill $fg -outline $fg -tags rect 2287 } else { 2288 $path.bar create rectangle 0 1 0 0 -fill $fg -outline $fg -tags rect 2289 } 2290 2291 set _widget($path,val) 0 2292 set _widget($path,dir) 1 2293 set _widget($path,var) [Widget::cget $path -variable] 2294 if {$_widget($path,var) != ""} { 2295 GlobalVar::tracevar variable $_widget($path,var) w \ 2296 [list ProgressBar::_modify $path] 2297 set _widget($path,afterid) \ 2298 [after idle [list ProgressBar::_modify $path]] 2299 } 2300 2301 bind $path.bar <Destroy> [list ProgressBar::_destroy $path] 2302 bind $path.bar <Configure> [list ProgressBar::_modify $path] 2303 2304 return [Widget::create ProgressBar $path] 2305} 2306 2307 2308# ---------------------------------------------------------------------------- 2309# Command ProgressBar::configure 2310# ---------------------------------------------------------------------------- 2311proc ProgressBar::configure { path args } { 2312 variable _widget 2313 2314 set res [Widget::configure $path $args] 2315 2316 if { [Widget::hasChangedX $path -variable] } { 2317 set newv [Widget::cget $path -variable] 2318 if { $_widget($path,var) != "" } { 2319 GlobalVar::tracevar vdelete $_widget($path,var) w \ 2320 [list ProgressBar::_modify $path] 2321 } 2322 if { $newv != "" } { 2323 set _widget($path,var) $newv 2324 GlobalVar::tracevar variable $newv w \ 2325 [list ProgressBar::_modify $path] 2326 if {![info exists _widget($path,afterid)]} { 2327 set _widget($path,afterid) \ 2328 [after idle [list ProgressBar::_modify $path]] 2329 } 2330 } else { 2331 set _widget($path,var) "" 2332 } 2333 } 2334 2335 foreach {cbd cor cma} [Widget::hasChangedX $path -borderwidth \ 2336 -orient -maximum] break 2337 2338 if { $cbd || $cor || $cma } { 2339 if {![info exists _widget($path,afterid)]} { 2340 set _widget($path,afterid) \ 2341 [after idle [list ProgressBar::_modify $path]] 2342 } 2343 } 2344 if { [Widget::hasChangedX $path -foreground] } { 2345 set fg [Widget::cget $path -foreground] 2346 $path.bar itemconfigure rect -fill $fg -outline $fg 2347 } 2348 return $res 2349} 2350 2351 2352# ---------------------------------------------------------------------------- 2353# Command ProgressBar::cget 2354# ---------------------------------------------------------------------------- 2355proc ProgressBar::cget { path option } { 2356 return [Widget::cget $path $option] 2357} 2358 2359 2360# ---------------------------------------------------------------------------- 2361# Command ProgressBar::_modify 2362# ---------------------------------------------------------------------------- 2363proc ProgressBar::_modify { path args } { 2364 variable _widget 2365 2366 catch {unset _widget($path,afterid)} 2367 if { ![GlobalVar::exists $_widget($path,var)] || 2368 [set val [GlobalVar::getvar $_widget($path,var)]] < 0 } { 2369 catch {place forget $path.bar} 2370 } else { 2371 place $path.bar -relx 0 -rely 0 -relwidth 1 -relheight 1 2372 set type [Widget::getoption $path -type] 2373 if { $val != 0 && $type != "normal" && \ 2374 $type != "nonincremental_infinite"} { 2375 set val [expr {$val+$_widget($path,val)}] 2376 } 2377 set _widget($path,val) $val 2378 set max [Widget::getoption $path -maximum] 2379 set bd [expr {2*[$path.bar cget -bd]}] 2380 set w [winfo width $path.bar] 2381 set h [winfo height $path.bar] 2382 if {$type == "infinite" || $type == "nonincremental_infinite"} { 2383 # JDC: New infinite behaviour 2384 set tval [expr {$val % $max}] 2385 if { $tval < ($max / 2.0) } { 2386 set x0 [expr {double($tval) / double($max) * 1.5}] 2387 } else { 2388 set x0 [expr {(1.0-(double($tval) / double($max))) * 1.5}] 2389 } 2390 set x1 [expr {$x0 + 0.25}] 2391 # convert coords to ints to prevent triggering canvas refresh 2392 # bug related to fractional coords 2393 if {[Widget::getoption $path -orient] == "horizontal"} { 2394 $path.bar coords rect [expr {int($x0*$w)}] 0 \ 2395 [expr {int($x1*$w)}] $h 2396 } else { 2397 $path.bar coords rect 0 [expr {int($h-$x0*$h)}] $w \ 2398 [expr {int($x1*$h)}] 2399 } 2400 } else { 2401 if { $val > $max } {set val $max} 2402 if {[Widget::getoption $path -orient] == "horizontal"} { 2403 $path.bar coords rect -1 0 [expr {int(double($val)*$w/$max)}] $h 2404 } else { 2405 $path.bar coords rect 0 [expr {$h+1}] $w \ 2406 [expr {int($h*(1.0 - double($val)/$max))}] 2407 } 2408 } 2409 } 2410 if {![Widget::cget $path -idle]} { 2411 update idletasks 2412 } 2413} 2414 2415 2416# ---------------------------------------------------------------------------- 2417# Command ProgressBar::_destroy 2418# ---------------------------------------------------------------------------- 2419proc ProgressBar::_destroy { path } { 2420 variable _widget 2421 2422 if {[info exists _widget($path,afterid)]} { 2423 after cancel $_widget($path,afterid) 2424 unset _widget($path,afterid) 2425 } 2426 if {[info exists _widget($path,var)]} { 2427 if {$_widget($path,var) != ""} { 2428 GlobalVar::tracevar vdelete $_widget($path,var) w \ 2429 [list ProgressBar::_modify $path] 2430 } 2431 unset _widget($path,var) 2432 } 2433 unset _widget($path,dir) 2434 Widget::destroy $path 2435} 2436