combobox.tcl
1 # Copyright (c) 1998-2002, Bryan Oakley 2 # All Rights Reservered 3 # 4 # Bryan Oakley 5 # oakley@bardo.clearlight.com 6 # 7 # combobox v2.2 September 22, 2002 8 # 9 # a combobox / dropdown listbox (pick your favorite name) widget 10 # written in pure tcl 11 # 12 # this code is freely distributable without restriction, but is 13 # provided as-is with no warranty expressed or implied. 14 # 15 # thanks to the following people who provided beta test support or 16 # patches to the code (in no particular order): 17 # 18 # Scott Beasley Alexandre Ferrieux Todd Helfter 19 # Matt Gushee Laurent Duperval John Jackson 20 # Fred Rapp Christopher Nelson 21 # Eric Galluzzo Jean-Francois Moine 22 # 23 # A special thanks to Martin M. Hunt who provided several good ideas, 24 # and always with a patch to implement them. Jean-Francois Moine, 25 # Todd Helfter and John Jackson were also kind enough to send in some 26 # code patches. 27 # 28 # ... and many others over the years. 29 30 package require Tk 8.0 31 package provide combobox 2.2 32 33 namespace eval ::combobox { 34 35 # this is the public interface 36 namespace export combobox 37 38 # these contain references to available options 39 variable widgetOptions 40 41 # these contain references to available commands and subcommands 42 variable widgetCommands 43 variable scanCommands 44 variable listCommands 45 } 46 47 # ::combobox::combobox -- 48 # 49 # This is the command that gets exported. It creates a new 50 # combobox widget. 51 # 52 # Arguments: 53 # 54 # w path of new widget to create 55 # args additional option/value pairs (eg: -background white, etc.) 56 # 57 # Results: 58 # 59 # It creates the widget and sets up all of the default bindings 60 # 61 # Returns: 62 # 63 # The name of the newly create widget 64 65 proc ::combobox::combobox {w args} { 66 variable widgetOptions 67 variable widgetCommands 68 variable scanCommands 69 variable listCommands 70 71 # perform a one time initialization 72 if {![info exists widgetOptions]} { 73 Init 74 } 75 76 # build it... 77 eval Build $w $args 78 79 # set some bindings... 80 SetBindings $w 81 82 # and we are done! 83 return $w 84 } 85 86 87 # ::combobox::Init -- 88 # 89 # Initialize the namespace variables. This should only be called 90 # once, immediately prior to creating the first instance of the 91 # widget 92 # 93 # Arguments: 94 # 95 # none 96 # 97 # Results: 98 # 99 # All state variables are set to their default values; all of 100 # the option database entries will exist. 101 # 102 # Returns: 103 # 104 # empty string 105 106 proc ::combobox::Init {} { 107 variable widgetOptions 108 variable widgetCommands 109 variable scanCommands 110 variable listCommands 111 variable defaultEntryCursor 112 113 array set widgetOptions [list \ 114 -background {background Background} \ 115 -bd -borderwidth \ 116 -bg -background \ 117 -borderwidth {borderWidth BorderWidth} \ 118 -command {command Command} \ 119 -commandstate {commandState State} \ 120 -cursor {cursor Cursor} \ 121 -disabledbackground {disabledBackground DisabledBackground} \ 122 -disabledforeground {disabledForeground DisabledForeground} \ 123 -dropdownwidth {dropdownWidth DropdownWidth} \ 124 -editable {editable Editable} \ 125 -fg -foreground \ 126 -font {font Font} \ 127 -foreground {foreground Foreground} \ 128 -height {height Height} \ 129 -highlightbackground {highlightBackground HighlightBackground} \ 130 -highlightcolor {highlightColor HighlightColor} \ 131 -highlightthickness {highlightThickness HighlightThickness} \ 132 -image {image Image} \ 133 -maxheight {maxHeight Height} \ 134 -opencommand {opencommand Command} \ 135 -relief {relief Relief} \ 136 -selectbackground {selectBackground Foreground} \ 137 -selectborderwidth {selectBorderWidth BorderWidth} \ 138 -selectforeground {selectForeground Background} \ 139 -state {state State} \ 140 -takefocus {takeFocus TakeFocus} \ 141 -textvariable {textVariable Variable} \ 142 -value {value Value} \ 143 -width {width Width} \ 144 -xscrollcommand {xScrollCommand ScrollCommand} \ 145 ] 146 147 148 set widgetCommands [list \ 149 bbox cget configure curselection \ 150 delete get icursor index \ 151 insert list scan selection \ 152 xview select toggle open \ 153 close \ 154 ] 155 156 set listCommands [list \ 157 delete get \ 158 index insert size \ 159 ] 160 161 set scanCommands [list mark dragto] 162 163 # why check for the Tk package? This lets us be sourced into 164 # an interpreter that doesn't have Tk loaded, such as the slave 165 # interpreter used by pkg_mkIndex. In theory it should have no 166 # side effects when run 167 if {[lsearch -exact [package names] "Tk"] != -1} { 168 169 ################################################################## 170 #- this initializes the option database. Kinda gross, but it works 171 #- (I think). 172 ################################################################## 173 174 # the image used for the button... 175 if {1} { 176 image create bitmap ::combobox::bimage -data { 177 #define down_arrow_width 15 178 #define down_arrow_height 14 179 static char down_arrow_bits[] = { 180 0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80, 181 0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83, 182 0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80, 183 0x00,0x80,0x00,0x80 184 } 185 } 186 } elseif {$::tcl_platform(platform) == "windows"} { 187 image create bitmap ::combobox::bimage -data { 188 #define down_arrow_width 12 189 #define down_arrow_height 12 190 static char down_arrow_bits[] = { 191 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 192 0xfc,0xf1,0xf8,0xf0,0x70,0xf0,0x20,0xf0, 193 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00; 194 } 195 } 196 } else { 197 image create bitmap ::combobox::bimage -data { 198 #define down_arrow_width 15 199 #define down_arrow_height 15 200 static char down_arrow_bits[] = { 201 0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80, 202 0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83, 203 0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80, 204 0x00,0x80,0x00,0x80,0x00,0x80 205 } 206 } 207 } 208 209 # compute a widget name we can use to create a temporary widget 210 set tmpWidget ".__tmp__" 211 set count 0 212 while {[winfo exists $tmpWidget] == 1} { 213 set tmpWidget ".__tmp__$count" 214 incr count 215 } 216 217 # get the scrollbar width. Because we try to be clever and draw our 218 # own button instead of using a tk widget, we need to know what size 219 # button to create. This little hack tells us the width of a scroll 220 # bar. 221 # 222 # NB: we need to be sure and pick a window that doesn't already 223 # exist... 224 scrollbar $tmpWidget 225 set sb_width [winfo reqwidth $tmpWidget] 226 destroy $tmpWidget 227 228 # steal options from the entry widget 229 # we want darn near all options, so we'll go ahead and do 230 # them all. No harm done in adding the one or two that we 231 # don't use. 232 entry $tmpWidget 233 foreach foo [$tmpWidget configure] { 234 # the cursor option is special, so we'll save it in 235 # a special way 236 if {[lindex $foo 0] == "-cursor"} { 237 set defaultEntryCursor [lindex $foo 4] 238 } 239 if {[llength $foo] == 5} { 240 set option [lindex $foo 1] 241 set value [lindex $foo 4] 242 option add *Combobox.$option $value widgetDefault 243 244 # these options also apply to the dropdown listbox 245 if {[string compare $option "foreground"] == 0 \ 246 || [string compare $option "background"] == 0 \ 247 || [string compare $option "font"] == 0} { 248 option add *Combobox*ComboboxListbox.$option $value \ 249 widgetDefault 250 } 251 } 252 } 253 destroy $tmpWidget 254 255 # these are unique to us... 256 option add *Combobox.dropdownWidth {} widgetDefault 257 option add *Combobox.openCommand {} widgetDefault 258 option add *Combobox.cursor {} widgetDefault 259 option add *Combobox.commandState normal widgetDefault 260 option add *Combobox.editable 1 widgetDefault 261 option add *Combobox.maxHeight 10 widgetDefault 262 option add *Combobox.height 0 263 } 264 265 # set class bindings 266 SetClassBindings 267 } 268 269 # ::combobox::SetClassBindings -- 270 # 271 # Sets up the default bindings for the widget class 272 # 273 # this proc exists since it's The Right Thing To Do, but 274 # I haven't had the time to figure out how to do all the 275 # binding stuff on a class level. The main problem is that 276 # the entry widget must have focus for the insertion cursor 277 # to be visible. So, I either have to have the entry widget 278 # have the Combobox bindtag, or do some fancy juggling of 279 # events or some such. What a pain. 280 # 281 # Arguments: 282 # 283 # none 284 # 285 # Returns: 286 # 287 # empty string 288 289 proc ::combobox::SetClassBindings {} { 290 291 # make sure we clean up after ourselves... 292 bind Combobox <Destroy> [list ::combobox::DestroyHandler %W] 293 294 # this will (hopefully) close (and lose the grab on) the 295 # listbox if the user clicks anywhere outside of it. Note 296 # that on Windows, you can click on some other app and 297 # the listbox will still be there, because tcl won't see 298 # that button click 299 set this {[::combobox::convert %W -W]} 300 bind Combobox <Any-ButtonPress> "$this close" 301 bind Combobox <Any-ButtonRelease> "$this close" 302 303 # this helps (but doesn't fully solve) focus issues. The general 304 # idea is, whenever the frame gets focus it gets passed on to 305 # the entry widget 306 bind Combobox <FocusIn> {::combobox::tkTabToWindow [::combobox::convert %W -W].entry} 307 308 # this closes the listbox if we get hidden 309 bind Combobox <Unmap> {[::combobox::convert %W -W] close} 310 311 return "" 312 } 313 314 # ::combobox::SetBindings -- 315 # 316 # here's where we do most of the binding foo. I think there's probably 317 # a few bindings I ought to add that I just haven't thought 318 # about... 319 # 320 # I'm not convinced these are the proper bindings. Ideally all 321 # bindings should be on "Combobox", but because of my juggling of 322 # bindtags I'm not convinced thats what I want to do. But, it all 323 # seems to work, its just not as robust as it could be. 324 # 325 # Arguments: 326 # 327 # w widget pathname 328 # 329 # Returns: 330 # 331 # empty string 332 333 proc ::combobox::SetBindings {w} { 334 upvar ::combobox::${w}::widgets widgets 335 upvar ::combobox::${w}::options options 336 337 # juggle the bindtags. The basic idea here is to associate the 338 # widget name with the entry widget, so if a user does a bind 339 # on the combobox it will get handled properly since it is 340 # the entry widget that has keyboard focus. 341 bindtags $widgets(entry) \ 342 [concat $widgets(this) [bindtags $widgets(entry)]] 343 344 bindtags $widgets(button) \ 345 [concat $widgets(this) [bindtags $widgets(button)]] 346 347 # override the default bindings for tab and shift-tab. The 348 # focus procs take a widget as their only parameter and we 349 # want to make sure the right window gets used (for shift- 350 # tab we want it to appear as if the event was generated 351 # on the frame rather than the entry. 352 bind $widgets(entry) <Tab> \ 353 "::combobox::tkTabToWindow \[tk_focusNext $widgets(entry)\]; break" 354 bind $widgets(entry) <Shift-Tab> \ 355 "::combobox::tkTabToWindow \[tk_focusPrev $widgets(this)\]; break" 356 357 # this makes our "button" (which is actually a label) 358 # do the right thing 359 bind $widgets(button) <ButtonPress-1> [list $widgets(this) toggle] 360 361 # this lets the autoscan of the listbox work, even if they 362 # move the cursor over the entry widget. 363 bind $widgets(entry) <B1-Enter> "break" 364 365 bind $widgets(listbox) <ButtonRelease-1> \ 366 "::combobox::Select [list $widgets(this)] \ 367 \[$widgets(listbox) nearest %y\]; break" 368 369 bind $widgets(vsb) <ButtonPress-1> {continue} 370 bind $widgets(vsb) <ButtonRelease-1> {continue} 371 372 bind $widgets(listbox) <Any-Motion> { 373 %W selection clear 0 end 374 %W activate @%x,%y 375 %W selection anchor @%x,%y 376 %W selection set @%x,%y @%x,%y 377 # need to do a yview if the cursor goes off the top 378 # or bottom of the window... (or do we?) 379 } 380 381 # these events need to be passed from the entry widget 382 # to the listbox, or otherwise need some sort of special 383 # handling. 384 foreach event [list <Up> <Down> <Tab> <Return> <Escape> \ 385 <Next> <Prior> <Double-1> <1> <Any-KeyPress> \ 386 <FocusIn> <FocusOut> <KeyRelease-Up> <KeyRelease-Down> \ 387 <KeyRelease-Next> <KeyRelease-Prior>] { 388 bind $widgets(entry) $event \ 389 [list ::combobox::HandleEvent $widgets(this) $event] 390 } 391 392 # like the other events, <MouseWheel> needs to be passed from 393 # the entry widget to the listbox. However, in this case we 394 # need to add an additional parameter 395 bind $widgets(entry) <MouseWheel> \ 396 [list ::combobox::HandleEvent $widgets(this) <MouseWheel> %D] 397 } 398 399 # ::combobox::Build -- 400 # 401 # This does all of the work necessary to create the basic 402 # combobox. 403 # 404 # Arguments: 405 # 406 # w widget name 407 # args additional option/value pairs 408 # 409 # Results: 410 # 411 # Creates a new widget with the given name. Also creates a new 412 # namespace patterened after the widget name, as a child namespace 413 # to ::combobox 414 # 415 # Returns: 416 # 417 # the name of the widget 418 419 proc ::combobox::Build {w args } { 420 variable widgetOptions 421 422 if {[winfo exists $w]} { 423 error "window name \"$w\" already exists" 424 } 425 426 # create the namespace for this instance, and define a few 427 # variables 428 namespace eval ::combobox::$w { 429 430 variable ignoreTrace 0 431 variable oldFocus {} 432 variable oldGrab {} 433 variable oldValue {} 434 variable options 435 variable this 436 variable widgets 437 438 set widgets(foo) foo ;# coerce into an array 439 set options(foo) foo ;# coerce into an array 440 441 unset widgets(foo) 442 unset options(foo) 443 } 444 445 # import the widgets and options arrays into this proc so 446 # we don't have to use fully qualified names, which is a 447 # pain. 448 upvar ::combobox::${w}::widgets widgets 449 upvar ::combobox::${w}::options options 450 451 # this is our widget -- a frame of class Combobox. Naturally, 452 # it will contain other widgets. We create it here because 453 # we need it in order to set some default options. 454 set widgets(this) [frame $w -class Combobox -takefocus 0 -width 0] 455 set widgets(entry) [entry $w.entry -takefocus 1] 456 set widgets(button) [label $w.button -takefocus 0] 457 458 # this defines all of the default options. We get the 459 # values from the option database. Note that if an array 460 # value is a list of length one it is an alias to another 461 # option, so we just ignore it 462 foreach name [array names widgetOptions] { 463 if {[llength $widgetOptions($name)] == 1} continue 464 465 set optName [lindex $widgetOptions($name) 0] 466 set optClass [lindex $widgetOptions($name) 1] 467 468 set value [option get $w $optName $optClass] 469 set options($name) $value 470 } 471 472 # a couple options aren't available in earlier versions of 473 # tcl, so we'll set them to sane values. For that matter, if 474 # they exist but are empty, set them to sane values. 475 if {[string length $options(-disabledforeground)] == 0} { 476 set options(-disabledforeground) $options(-foreground) 477 } 478 if {[string length $options(-disabledbackground)] == 0} { 479 set options(-disabledbackground) $options(-background) 480 } 481 482 # if -value is set to null, we'll remove it from our 483 # local array. The assumption is, if the user sets it from 484 # the option database, they will set it to something other 485 # than null (since it's impossible to determine the difference 486 # between a null value and no value at all). 487 if {[info exists options(-value)] \ 488 && [string length $options(-value)] == 0} { 489 unset options(-value) 490 } 491 492 # we will later rename the frame's widget proc to be our 493 # own custom widget proc. We need to keep track of this 494 # new name, so we'll define and store it here... 495 set widgets(frame) ::combobox::${w}::$w 496 497 # gotta do this sooner or later. Might as well do it now 498 pack $widgets(entry) -side left -fill both -expand yes 499 pack $widgets(button) -side right -fill y -expand no 500 501 # I should probably do this in a catch, but for now it's 502 # good enough... What it does, obviously, is put all of 503 # the option/values pairs into an array. Make them easier 504 # to handle later on... 505 array set options $args 506 507 # now, the dropdown list... the same renaming nonsense 508 # must go on here as well... 509 set widgets(dropdown) [toplevel $w.top] 510 set widgets(listbox) [listbox $w.top.list] 511 set widgets(vsb) [scrollbar $w.top.vsb] 512 513 pack $widgets(listbox) -side left -fill both -expand y 514 515 # fine tune the widgets based on the options (and a few 516 # arbitrary values...) 517 518 # NB: we are going to use the frame to handle the relief 519 # of the widget as a whole, so the entry widget will be 520 # flat. This makes the button which drops down the list 521 # to appear "inside" the entry widget. 522 523 $widgets(vsb) configure \ 524 -command "$widgets(listbox) yview" \ 525 -highlightthickness 0 526 527 $widgets(button) configure \ 528 -highlightthickness 0 \ 529 -borderwidth 1 \ 530 -relief raised \ 531 -width [expr {[winfo reqwidth $widgets(vsb)] - 2}] 532 533 $widgets(entry) configure \ 534 -borderwidth 0 \ 535 -relief flat \ 536 -highlightthickness 0 537 538 $widgets(dropdown) configure \ 539 -borderwidth 1 \ 540 -relief sunken 541 542 $widgets(listbox) configure \ 543 -selectmode browse \ 544 -background [$widgets(entry) cget -bg] \ 545 -yscrollcommand "$widgets(vsb) set" \ 546 -exportselection false \ 547 -borderwidth 0 548 549 550 # trace variable ::combobox::${w}::entryTextVariable w \ 551 # [list ::combobox::EntryTrace $w] 552 553 # do some window management foo on the dropdown window 554 wm overrideredirect $widgets(dropdown) 1 555 wm transient $widgets(dropdown) [winfo toplevel $w] 556 wm group $widgets(dropdown) [winfo parent $w] 557 wm resizable $widgets(dropdown) 0 0 558 wm withdraw $widgets(dropdown) 559 560 # this moves the original frame widget proc into our 561 # namespace and gives it a handy name 562 rename ::$w $widgets(frame) 563 564 # now, create our widget proc. Obviously (?) it goes in 565 # the global namespace. All combobox widgets will actually 566 # share the same widget proc to cut down on the amount of 567 # bloat. 568 proc ::$w {command args} \ 569 "eval ::combobox::WidgetProc $w \$command \$args" 570 571 572 # ok, the thing exists... let's do a bit more configuration. 573 if {[catch "::combobox::Configure [list $widgets(this)] [array get options]" error]} { 574 catch {destroy $w} 575 error "internal error: $error" 576 } 577 578 return "" 579 580 } 581 582 # ::combobox::HandleEvent -- 583 # 584 # this proc handles events from the entry widget that we want 585 # handled specially (typically, to allow navigation of the list 586 # even though the focus is in the entry widget) 587 # 588 # Arguments: 589 # 590 # w widget pathname 591 # event a string representing the event (not necessarily an 592 # actual event) 593 # args additional arguments required by particular events 594 595 proc ::combobox::HandleEvent {w event args} { 596 upvar ::combobox::${w}::widgets widgets 597 upvar ::combobox::${w}::options options 598 upvar ::combobox::${w}::oldValue oldValue 599 600 # for all of these events, if we have a special action we'll 601 # do that and do a "return -code break" to keep additional 602 # bindings from firing. Otherwise we'll let the event fall 603 # on through. 604 switch $event { 605 606 "<MouseWheel>" { 607 if {[winfo ismapped $widgets(dropdown)]} { 608 set D [lindex $args 0] 609 # the '120' number in the following expression has 610 # it's genesis in the tk bind manpage, which suggests 611 # that the smallest value of %D for mousewheel events 612 # will be 120. The intent is to scroll one line at a time. 613 $widgets(listbox) yview scroll [expr {-($D/120)}] units 614 } 615 } 616 617 "<Any-KeyPress>" { 618 # if the widget is editable, clear the selection. 619 # this makes it more obvious what will happen if the 620 # user presses <Return> (and helps our code know what 621 # to do if the user presses return) 622 if {$options(-editable)} { 623 $widgets(listbox) see 0 624 $widgets(listbox) selection clear 0 end 625 $widgets(listbox) selection anchor 0 626 $widgets(listbox) activate 0 627 } 628 } 629 630 "<FocusIn>" { 631 set oldValue [$widgets(entry) get] 632 } 633 634 "<FocusOut>" { 635 if {![winfo ismapped $widgets(dropdown)]} { 636 # did the value change? 637 set newValue [$widgets(entry) get] 638 if {$oldValue != $newValue} { 639 CallCommand $widgets(this) $newValue 640 } 641 } 642 } 643 644 "<1>" { 645 set editable [::combobox::GetBoolean $options(-editable)] 646 if {!$editable} { 647 if {[winfo ismapped $widgets(dropdown)]} { 648 $widgets(this) close 649 return -code break; 650 651 } else { 652 if {$options(-state) != "disabled"} { 653 $widgets(this) open 654 return -code break; 655 } 656 } 657 } 658 } 659 660 "<Double-1>" { 661 if {$options(-state) != "disabled"} { 662 $widgets(this) toggle 663 return -code break; 664 } 665 } 666 667 "<Tab>" { 668 if {[winfo ismapped $widgets(dropdown)]} { 669 ::combobox::Find $widgets(this) 0 670 return -code break; 671 } else { 672 ::combobox::SetValue $widgets(this) [$widgets(this) get] 673 } 674 } 675 676 "<Escape>" { 677 # $widgets(entry) delete 0 end 678 # $widgets(entry) insert 0 $oldValue 679 if {[winfo ismapped $widgets(dropdown)]} { 680 $widgets(this) close 681 return -code break; 682 } 683 } 684 685 "<Return>" { 686 # did the value change? 687 set newValue [$widgets(entry) get] 688 if {$oldValue != $newValue} { 689 CallCommand $widgets(this) $newValue 690 } 691 692 if {[winfo ismapped $widgets(dropdown)]} { 693 ::combobox::Select $widgets(this) \ 694 [$widgets(listbox) curselection] 695 return -code break; 696 } 697 698 } 699 700 "<Next>" { 701 $widgets(listbox) yview scroll 1 pages 702 set index [$widgets(listbox) index @0,0] 703 $widgets(listbox) see $index 704 $widgets(listbox) activate $index 705 $widgets(listbox) selection clear 0 end 706 $widgets(listbox) selection anchor $index 707 $widgets(listbox) selection set $index 708 return -code break; 709 710 } 711 712 "<Prior>" { 713 $widgets(listbox) yview scroll -1 pages 714 set index [$widgets(listbox) index @0,0] 715 $widgets(listbox) activate $index 716 $widgets(listbox) see $index 717 $widgets(listbox) selection clear 0 end 718 $widgets(listbox) selection anchor $index 719 $widgets(listbox) selection set $index 720 return -code break; 721 } 722 723 "<Down>" { 724 if {[winfo ismapped $widgets(dropdown)]} { 725 ::combobox::tkListboxUpDown $widgets(listbox) 1 726 } else { 727 if {$options(-state) != "disabled"} { 728 $widgets(this) open 729 } 730 } 731 return -code break; 732 } 733 "<Up>" { 734 if {[winfo ismapped $widgets(dropdown)]} { 735 ::combobox::tkListboxUpDown $widgets(listbox) -1 736 } else { 737 if {$options(-state) != "disabled"} { 738 $widgets(this) open 739 } 740 } 741 return -code break; 742 } 743 744 "<KeyRelease-Up>" - "<KeyRelease-Down>" - 745 "<KeyRelease-Next>" - "<KeyRelease-Prior>" { 746 if {[winfo ismapped $widgets(dropdown)]} { 747 return -code break; 748 } 749 } 750 } 751 752 return "" 753 } 754 755 # ::combobox::DestroyHandler {w} -- 756 # 757 # Cleans up after a combobox widget is destroyed 758 # 759 # Arguments: 760 # 761 # w widget pathname 762 # 763 # Results: 764 # 765 # The namespace that was created for the widget is deleted, 766 # and the widget proc is removed. 767 768 proc ::combobox::DestroyHandler {w} { 769 770 # if the widget actually being destroyed is of class Combobox, 771 # crush the namespace and kill the proc. Get it? Crush. Kill. 772 # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it 773 # brings tears to my eyes. 774 if {[string compare [winfo class $w] "Combobox"] == 0} { 775 upvar ::combobox::${w}::widgets widgets 776 upvar ::combobox::${w}::options options 777 778 # delete the namespace and the proc which represents 779 # our widget 780 namespace delete ::combobox::$w 781 rename $w {} 782 } 783 784 return "" 785 } 786 787 # ::combobox::Find 788 # 789 # finds something in the listbox that matches the pattern in the 790 # entry widget and selects it 791 # 792 # N.B. I'm not convinced this is working the way it ought to. It 793 # works, but is the behavior what is expected? I've also got a gut 794 # feeling that there's a better way to do this, but I'm too lazy to 795 # figure it out... 796 # 797 # Arguments: 798 # 799 # w widget pathname 800 # exact boolean; if true an exact match is desired 801 # 802 # Returns: 803 # 804 # Empty string 805 806 proc ::combobox::Find {w {exact 0}} { 807 upvar ::combobox::${w}::widgets widgets 808 upvar ::combobox::${w}::options options 809 810 ## *sigh* this logic is rather gross and convoluted. Surely 811 ## there is a more simple, straight-forward way to implement 812 ## all this. As the saying goes, I lack the time to make it 813 ## shorter... 814 815 # use what is already in the entry widget as a pattern 816 set pattern [$widgets(entry) get] 817 818 if {[string length $pattern] == 0} { 819 # clear the current selection 820 $widgets(listbox) see 0 821 $widgets(listbox) selection clear 0 end 822 $widgets(listbox) selection anchor 0 823 $widgets(listbox) activate 0 824 return 825 } 826 827 # we're going to be searching this list... 828 set list [$widgets(listbox) get 0 end] 829 830 # if we are doing an exact match, try to find, 831 # well, an exact match 832 set exactMatch -1 833 if {$exact} { 834 set exactMatch [lsearch -exact $list $pattern] 835 } 836 837 # search for it. We'll try to be clever and not only 838 # search for a match for what they typed, but a match for 839 # something close to what they typed. We'll keep removing one 840 # character at a time from the pattern until we find a match 841 # of some sort. 842 set index -1 843 while {$index == -1 && [string length $pattern]} { 844 set index [lsearch -glob $list "$pattern*"] 845 if {$index == -1} { 846 regsub {.$} $pattern {} pattern 847 } 848 } 849 850 # this is the item that most closely matches... 851 set thisItem [lindex $list $index] 852 853 # did we find a match? If so, do some additional munging... 854 if {$index != -1} { 855 856 # we need to find the part of the first item that is 857 # unique WRT the second... I know there's probably a 858 # simpler way to do this... 859 860 set nextIndex [expr {$index + 1}] 861 set nextItem [lindex $list $nextIndex] 862 863 # we don't really need to do much if the next 864 # item doesn't match our pattern... 865 if {[string match $pattern* $nextItem]} { 866 # ok, the next item matches our pattern, too 867 # now the trick is to find the first character 868 # where they *don't* match... 869 set marker [string length $pattern] 870 while {$marker <= [string length $pattern]} { 871 set a [string index $thisItem $marker] 872 set b [string index $nextItem $marker] 873 if {[string compare $a $b] == 0} { 874 append pattern $a 875 incr marker 876 } else { 877 break 878 } 879 } 880 } else { 881 set marker [string length $pattern] 882 } 883 884 } else { 885 set marker end 886 set index 0 887 } 888 889 # ok, we know the pattern and what part is unique; 890 # update the entry widget and listbox appropriately 891 if {$exact && $exactMatch == -1} { 892 # this means we didn't find an exact match 893 $widgets(listbox) selection clear 0 end 894 $widgets(listbox) see $index 895 896 } elseif {!$exact} { 897 # this means we found something, but it isn't an exact 898 # match. If we find something that *is* an exact match we 899 # don't need to do the following, since it would merely 900 # be replacing the data in the entry widget with itself 901 set oldstate [$widgets(entry) cget -state] 902 $widgets(entry) configure -state normal 903 $widgets(entry) delete 0 end 904 $widgets(entry) insert end $thisItem 905 $widgets(entry) selection clear 906 $widgets(entry) selection range $marker end 907 $widgets(listbox) activate $index 908 $widgets(listbox) selection clear 0 end 909 $widgets(listbox) selection anchor $index 910 $widgets(listbox) selection set $index 911 $widgets(listbox) see $index 912 $widgets(entry) configure -state $oldstate 913 } 914 } 915 916 # ::combobox::Select -- 917 # 918 # selects an item from the list and sets the value of the combobox 919 # to that value 920 # 921 # Arguments: 922 # 923 # w widget pathname 924 # index listbox index of item to be selected 925 # 926 # Returns: 927 # 928 # empty string 929 930 proc ::combobox::Select {w index} { 931 upvar ::combobox::${w}::widgets widgets 932 upvar ::combobox::${w}::options options 933 934 if {$index != ""} { 935 set data [$widgets(listbox) get [lindex $index 0]] 936 ::combobox::SetValue $widgets(this) $data 937 938 $widgets(listbox) selection clear 0 end 939 $widgets(listbox) selection anchor $index 940 $widgets(listbox) selection set $index 941 942 $widgets(entry) selection range 0 end 943 } 944 945 $widgets(this) close 946 947 return "" 948 } 949 950 # ::combobox::HandleScrollbar -- 951 # 952 # causes the scrollbar of the dropdown list to appear or disappear 953 # based on the contents of the dropdown listbox 954 # 955 # Arguments: 956 # 957 # w widget pathname 958 # action the action to perform on the scrollbar 959 # 960 # Returns: 961 # 962 # an empty string 963 964 proc ::combobox::HandleScrollbar {w {action "unknown"}} { 965 upvar ::combobox::${w}::widgets widgets 966 upvar ::combobox::${w}::options options 967 968 if {$options(-height) == 0} { 969 set hlimit $options(-maxheight) 970 } else { 971 set hlimit $options(-height) 972 } 973 974 switch $action { 975 "grow" { 976 if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} { 977 pack $widgets(vsb) -side right -fill y -expand n 978 } 979 } 980 981 "shrink" { 982 if {$hlimit > 0 && [$widgets(listbox) size] <= $hlimit} { 983 pack forget $widgets(vsb) 984 } 985 } 986 987 "crop" { 988 # this means the window was cropped and we definitely 989 # need a scrollbar no matter what the user wants 990 pack $widgets(vsb) -side right -fill y -expand n 991 } 992 993 default { 994 if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} { 995 pack $widgets(vsb) -side right -fill y -expand n 996 } else { 997 pack forget $widgets(vsb) 998 } 999 } 1000 } 1001 1002 return "" 1003 } 1004 1005 # ::combobox::ComputeGeometry -- 1006 # 1007 # computes the geometry of the dropdown list based on the size of the 1008 # combobox... 1009 # 1010 # Arguments: 1011 # 1012 # w widget pathname 1013 # 1014 # Returns: 1015 # 1016 # the desired geometry of the listbox 1017 1018 proc ::combobox::ComputeGeometry {w} { 1019 upvar ::combobox::${w}::widgets widgets 1020 upvar ::combobox::${w}::options options 1021 1022 if {$options(-height) == 0 && $options(-maxheight) != "0"} { 1023 # if this is the case, count the items and see if 1024 # it exceeds our maxheight. If so, set the listbox 1025 # size to maxheight... 1026 set nitems [$widgets(listbox) size] 1027 if {$nitems > $options(-maxheight)} { 1028 # tweak the height of the listbox 1029 $widgets(listbox) configure -height $options(-maxheight) 1030 } else { 1031 # un-tweak the height of the listbox 1032 $widgets(listbox) configure -height 0 1033 } 1034 update idletasks 1035 } 1036 1037 # compute height and width of the dropdown list 1038 set bd [$widgets(dropdown) cget -borderwidth] 1039 set height [expr {[winfo reqheight $widgets(dropdown)] + $bd + $bd}] 1040 if {[string length $options(-dropdownwidth)] == 0 || 1041 $options(-dropdownwidth) == 0} { 1042 set width [winfo width $widgets(this)] 1043 } else { 1044 set m [font measure [$widgets(listbox) cget -font] "m"] 1045 set width [expr {$options(-dropdownwidth) * $m}] 1046 } 1047 1048 # figure out where to place it on the screen, trying to take into 1049 # account we may be running under some virtual window manager 1050 set screenWidth [winfo screenwidth $widgets(this)] 1051 set screenHeight [winfo screenheight $widgets(this)] 1052 set rootx [winfo rootx $widgets(this)] 1053 set rooty [winfo rooty $widgets(this)] 1054 set vrootx [winfo vrootx $widgets(this)] 1055 set vrooty [winfo vrooty $widgets(this)] 1056 1057 # the x coordinate is simply the rootx of our widget, adjusted for 1058 # the virtual window. We won't worry about whether the window will 1059 # be offscreen to the left or right -- we want the illusion that it 1060 # is part of the entry widget, so if part of the entry widget is off- 1061 # screen, so will the list. If you want to change the behavior, 1062 # simply change the if statement... (and be sure to update this 1063 # comment!) 1064 set x [expr {$rootx + $vrootx}] 1065 if {0} { 1066 set rightEdge [expr {$x + $width}] 1067 if {$rightEdge > $screenWidth} { 1068 set x [expr {$screenWidth - $width}] 1069 } 1070 if {$x < 0} {set x 0} 1071 } 1072 1073 # the y coordinate is the rooty plus vrooty offset plus 1074 # the height of the static part of the widget plus 1 for a 1075 # tiny bit of visual separation... 1076 set y [expr {$rooty + $vrooty + [winfo reqheight $widgets(this)] + 1}] 1077 set bottomEdge [expr {$y + $height}] 1078 1079 if {$bottomEdge >= $screenHeight} { 1080 # ok. Fine. Pop it up above the entry widget isntead of 1081 # below. 1082 set y [expr {($rooty - $height - 1) + $vrooty}] 1083 1084 if {$y < 0} { 1085 # this means it extends beyond our screen. How annoying. 1086 # Now we'll try to be real clever and either pop it up or 1087 # down, depending on which way gives us the biggest list. 1088 # then, we'll trim the list to fit and force the use of 1089 # a scrollbar 1090 1091 # (sadly, for windows users this measurement doesn't 1092 # take into consideration the height of the taskbar, 1093 # but don't blame me -- there isn't any way to detect 1094 # it or figure out its dimensions. The same probably 1095 # applies to any window manager with some magic windows 1096 # glued to the top or bottom of the screen) 1097 1098 if {$rooty > [expr {$screenHeight / 2}]} { 1099 # we are in the lower half of the screen -- 1100 # pop it up. Y is zero; that parts easy. The height 1101 # is simply the y coordinate of our widget, minus 1102 # a pixel for some visual separation. The y coordinate 1103 # will be the topof the screen. 1104 set y 1 1105 set height [expr {$rooty - 1 - $y}] 1106 1107 } else { 1108 # we are in the upper half of the screen -- 1109 # pop it down 1110 set y [expr {$rooty + $vrooty + \ 1111 [winfo reqheight $widgets(this)] + 1}] 1112 set height [expr {$screenHeight - $y}] 1113 1114 } 1115 1116 # force a scrollbar 1117 HandleScrollbar $widgets(this) crop 1118 } 1119 } 1120 1121 if {$y < 0} { 1122 # hmmm. Bummer. 1123 set y 0 1124 set height $screenheight 1125 } 1126 1127 set geometry [format "=%dx%d+%d+%d" $width $height $x $y] 1128 1129 return $geometry 1130 } 1131 1132 # ::combobox::DoInternalWidgetCommand -- 1133 # 1134 # perform an internal widget command, then mung any error results 1135 # to look like it came from our megawidget. A lot of work just to 1136 # give the illusion that our megawidget is an atomic widget 1137 # 1138 # Arguments: 1139 # 1140 # w widget pathname 1141 # subwidget pathname of the subwidget 1142 # command subwidget command to be executed 1143 # args arguments to the command 1144 # 1145 # Returns: 1146 # 1147 # The result of the subwidget command, or an error 1148 1149 proc ::combobox::DoInternalWidgetCommand {w subwidget command args} { 1150 upvar ::combobox::${w}::widgets widgets 1151 upvar ::combobox::${w}::options options 1152 1153 set subcommand $command 1154 set command [concat $widgets($subwidget) $command $args] 1155 if {[catch $command result]} { 1156 # replace the subwidget name with the megawidget name 1157 regsub $widgets($subwidget) $result $widgets(this) result 1158 1159 # replace specific instances of the subwidget command 1160 # with out megawidget command 1161 switch $subwidget,$subcommand { 1162 listbox,index {regsub "index" $result "list index" result} 1163 listbox,insert {regsub "insert" $result "list insert" result} 1164 listbox,delete {regsub "delete" $result "list delete" result} 1165 listbox,get {regsub "get" $result "list get" result} 1166 listbox,size {regsub "size" $result "list size" result} 1167 } 1168 error $result 1169 1170 } else { 1171 return $result 1172 } 1173 } 1174 1175 1176 # ::combobox::WidgetProc -- 1177 # 1178 # This gets uses as the widgetproc for an combobox widget. 1179 # Notice where the widget is created and you'll see that the 1180 # actual widget proc merely evals this proc with all of the 1181 # arguments intact. 1182 # 1183 # Note that some widget commands are defined "inline" (ie: 1184 # within this proc), and some do most of their work in 1185 # separate procs. This is merely because sometimes it was 1186 # easier to do it one way or the other. 1187 # 1188 # Arguments: 1189 # 1190 # w widget pathname 1191 # command widget subcommand 1192 # args additional arguments; varies with the subcommand 1193 # 1194 # Results: 1195 # 1196 # Performs the requested widget command 1197 1198 proc ::combobox::WidgetProc {w command args} { 1199 upvar ::combobox::${w}::widgets widgets 1200 upvar ::combobox::${w}::options options 1201 upvar ::combobox::${w}::oldFocus oldFocus 1202 upvar ::combobox::${w}::oldGrab oldGrab 1203 1204 set command [::combobox::Canonize $w command $command] 1205 1206 # this is just shorthand notation... 1207 set doWidgetCommand \ 1208 [list ::combobox::DoInternalWidgetCommand $widgets(this)] 1209 1210 if {$command == "list"} { 1211 # ok, the next argument is a list command; we'll 1212 # rip it from args and append it to command to 1213 # create a unique internal command 1214 # 1215 # NB: because of the sloppy way we are doing this, 1216 # we'll also let the user enter our secret command 1217 # directly (eg: listinsert, listdelete), but we 1218 # won't document that fact 1219 set command "list-[lindex $args 0]" 1220 set args [lrange $args 1 end] 1221 } 1222 1223 set result "" 1224 1225 # many of these commands are just synonyms for specific 1226 # commands in one of the subwidgets. We'll get them out 1227 # of the way first, then do the custom commands. 1228 switch $command { 1229 bbox - 1230 delete - 1231 get - 1232 icursor - 1233 index - 1234 insert - 1235 scan - 1236 selection - 1237 xview { 1238 set result [eval $doWidgetCommand entry $command $args] 1239 } 1240 list-get {set result [eval $doWidgetCommand listbox get $args]} 1241 list-index {set result [eval $doWidgetCommand listbox index $args]} 1242 list-size {set result [eval $doWidgetCommand listbox size $args]} 1243 1244 select { 1245 if {[llength $args] == 1} { 1246 set index [lindex $args 0] 1247 set result [Select $widgets(this) $index] 1248 } else { 1249 error "usage: $w select index" 1250 } 1251 } 1252 1253 subwidget { 1254 set knownWidgets [list button entry listbox dropdown vsb] 1255 if {[llength $args] == 0} { 1256 return $knownWidgets 1257 } 1258 1259 set name [lindex $args 0] 1260 if {[lsearch $knownWidgets $name] != -1} { 1261 set result $widgets($name) 1262 } else { 1263 error "unknown subwidget $name" 1264 } 1265 } 1266 1267 curselection { 1268 set result [eval $doWidgetCommand listbox curselection] 1269 } 1270 1271 list-insert { 1272 eval $doWidgetCommand listbox insert $args 1273 set result [HandleScrollbar $w "grow"] 1274 } 1275 1276 list-delete { 1277 eval $doWidgetCommand listbox delete $args 1278 set result [HandleScrollbar $w "shrink"] 1279 } 1280 1281 toggle { 1282 # ignore this command if the widget is disabled... 1283 if {$options(-state) == "disabled"} return 1284 1285 # pops down the list if it is not, hides it 1286 # if it is... 1287 if {[winfo ismapped $widgets(dropdown)]} { 1288 set result [$widgets(this) close] 1289 } else { 1290 set result [$widgets(this) open] 1291 } 1292 } 1293 1294 open { 1295 1296 # if this is an editable combobox, the focus should 1297 # be set to the entry widget 1298 if {$options(-editable)} { 1299 focus $widgets(entry) 1300 $widgets(entry) select range 0 end 1301 $widgets(entry) icur end 1302 } 1303 1304 # if we are disabled, we won't allow this to happen 1305 if {$options(-state) == "disabled"} { 1306 return 0 1307 } 1308 1309 # if there is a -opencommand, execute it now 1310 if {[string length $options(-opencommand)] > 0} { 1311 # hmmm... should I do a catch, or just let the normal 1312 # error handling handle any errors? For now, the latter... 1313 uplevel \#0 $options(-opencommand) 1314 } 1315 1316 # compute the geometry of the window to pop up, and set 1317 # it, and force the window manager to take notice 1318 # (even if it is not presently visible). 1319 # 1320 # this isn't strictly necessary if the window is already 1321 # mapped, but we'll go ahead and set the geometry here 1322 # since its harmless and *may* actually reset the geometry 1323 # to something better in some weird case. 1324 set geometry [::combobox::ComputeGeometry $widgets(this)] 1325 wm geometry $widgets(dropdown) $geometry 1326 update idletasks 1327 1328 # if we are already open, there's nothing else to do 1329 if {[winfo ismapped $widgets(dropdown)]} { 1330 return 0 1331 } 1332 1333 # save the widget that currently has the focus; we'll restore 1334 # the focus there when we're done 1335 set oldFocus [focus] 1336 1337 # ok, tweak the visual appearance of things and 1338 # make the list pop up 1339 $widgets(button) configure -relief sunken 1340 raise $widgets(dropdown) [winfo parent $widgets(this)] 1341 wm deiconify $widgets(dropdown) 1342 1343 # force focus to the entry widget so we can handle keypress 1344 # events for traversal 1345 focus -force $widgets(entry) 1346 1347 # select something by default, but only if its an 1348 # exact match... 1349 ::combobox::Find $widgets(this) 1 1350 1351 # save the current grab state for the display containing 1352 # this widget. We'll restore it when we close the dropdown 1353 # list 1354 set status "none" 1355 set grab [grab current $widgets(this)] 1356 if {$grab != ""} {set status [grab status $grab]} 1357 set oldGrab [list $grab $status] 1358 unset grab status 1359 1360 # *gasp* do a global grab!!! Mom always told me not to 1361 # do things like this, but sometimes a man's gotta do 1362 # what a man's gotta do. 1363 grab -global $widgets(this) 1364 1365 # fake the listbox into thinking it has focus. This is 1366 # necessary to get scanning initialized properly in the 1367 # listbox. 1368 event generate $widgets(listbox) <B1-Enter> 1369 1370 # This seems to be necessary on certain window managers 1371 # including twm and fluxbox 1372 after idle raise $widgets(dropdown) 1373 1374 return 1 1375 } 1376 1377 close { 1378 # if we are already closed, don't do anything... 1379 if {![winfo ismapped $widgets(dropdown)]} { 1380 return 0 1381 } 1382 1383 # restore the focus and grab, but ignore any errors... 1384 # we're going to be paranoid and release the grab before 1385 # trying to set any other grab because we really really 1386 # really want to make sure the grab is released. 1387 catch {focus $oldFocus} result 1388 catch {grab release $widgets(this)} 1389 catch { 1390 set status [lindex $oldGrab 1] 1391 if {$status == "global"} { 1392 grab -global [lindex $oldGrab 0] 1393 } elseif {$status == "local"} { 1394 grab [lindex $oldGrab 0] 1395 } 1396 unset status 1397 } 1398 1399 # hides the listbox 1400 $widgets(button) configure -relief raised 1401 wm withdraw $widgets(dropdown) 1402 1403 # select the data in the entry widget. Not sure 1404 # why, other than observation seems to suggest that's 1405 # what windows widgets do. 1406 set editable [::combobox::GetBoolean $options(-editable)] 1407 if {$editable} { 1408 $widgets(entry) selection range 0 end 1409 $widgets(button) configure -relief raised 1410 } 1411 1412 1413 # magic tcl stuff (see tk.tcl in the distribution 1414 # lib directory) 1415 ::combobox::tkCancelRepeat 1416 1417 return 1 1418 } 1419 1420 cget { 1421 if {[llength $args] != 1} { 1422 error "wrong # args: should be $w cget option" 1423 } 1424 set opt [::combobox::Canonize $w option [lindex $args 0]] 1425 1426 if {$opt == "-value"} { 1427 set result [$widgets(entry) get] 1428 } else { 1429 set result $options($opt) 1430 } 1431 } 1432 1433 configure { 1434 set result [eval ::combobox::Configure {$w} $args] 1435 } 1436 1437 default { 1438 error "bad option \"$command\"" 1439 } 1440 } 1441 1442 return $result 1443 } 1444 1445 # ::combobox::Configure -- 1446 # 1447 # Implements the "configure" widget subcommand 1448 # 1449 # Arguments: 1450 # 1451 # w widget pathname 1452 # args zero or more option/value pairs (or a single option) 1453 # 1454 # Results: 1455 # 1456 # Performs typcial "configure" type requests on the widget 1457 1458 proc ::combobox::Configure {w args} { 1459 variable widgetOptions 1460 variable defaultEntryCursor 1461 1462 upvar ::combobox::${w}::widgets widgets 1463 upvar ::combobox::${w}::options options 1464 1465 if {[llength $args] == 0} { 1466 # hmmm. User must be wanting all configuration information 1467 # note that if the value of an array element is of length 1468 # one it is an alias, which needs to be handled slightly 1469 # differently 1470 set results {} 1471 foreach opt [lsort [array names widgetOptions]] { 1472 if {[llength $widgetOptions($opt)] == 1} { 1473 set alias $widgetOptions($opt) 1474 set optName $widgetOptions($alias) 1475 lappend results [list $opt $optName] 1476 } else { 1477 set optName [lindex $widgetOptions($opt) 0] 1478 set optClass [lindex $widgetOptions($opt) 1] 1479 set default [option get $w $optName $optClass] 1480 if {[info exists options($opt)]} { 1481 lappend results [list $opt $optName $optClass \ 1482 $default $options($opt)] 1483 } else { 1484 lappend results [list $opt $optName $optClass \ 1485 $default ""] 1486 } 1487 } 1488 } 1489 1490 return $results 1491 } 1492 1493 # one argument means we are looking for configuration 1494 # information on a single option 1495 if {[llength $args] == 1} { 1496 set opt [::combobox::Canonize $w option [lindex $args 0]] 1497 1498 set optName [lindex $widgetOptions($opt) 0] 1499 set optClass [lindex $widgetOptions($opt) 1] 1500 set default [option get $w $optName $optClass] 1501 set results [list $opt $optName $optClass \ 1502 $default $options($opt)] 1503 return $results 1504 } 1505 1506 # if we have an odd number of values, bail. 1507 if {[expr {[llength $args]%2}] == 1} { 1508 # hmmm. An odd number of elements in args 1509 error "value for \"[lindex $args end]\" missing" 1510 } 1511 1512 # Great. An even number of options. Let's make sure they 1513 # are all valid before we do anything. Note that Canonize 1514 # will generate an error if it finds a bogus option; otherwise 1515 # it returns the canonical option name 1516 foreach {name value} $args { 1517 set name [::combobox::Canonize $w option $name] 1518 set opts($name) $value 1519 } 1520 1521 # process all of the configuration options 1522 # some (actually, most) options require us to 1523 # do something, like change the attributes of 1524 # a widget or two. Here's where we do that... 1525 # 1526 # note that the handling of disabledforeground and 1527 # disabledbackground is a little wonky. First, we have 1528 # to deal with backwards compatibility (ie: tk 8.3 and below 1529 # didn't have such options for the entry widget), and 1530 # we have to deal with the fact we might want to disable 1531 # the entry widget but use the normal foreground/background 1532 # for when the combobox is not disabled, but not editable either. 1533 1534 set updateVisual 0 1535 foreach option [array names opts] { 1536 set newValue $opts($option) 1537 if {[info exists options($option)]} { 1538 set oldValue $options($option) 1539 } 1540 1541 switch -- $option { 1542 -background { 1543 set updateVisual 1 1544 set options($option) $newValue 1545 } 1546 1547 -borderwidth { 1548 $widgets(frame) configure -borderwidth $newValue 1549 set options($option) $newValue 1550 } 1551 1552 -command { 1553 # nothing else to do... 1554 set options($option) $newValue 1555 } 1556 1557 -commandstate { 1558 # do some value checking... 1559 if {$newValue != "normal" && $newValue != "disabled"} { 1560 set options($option) $oldValue 1561 set message "bad state value \"$newValue\";" 1562 append message " must be normal or disabled" 1563 error $message 1564 } 1565 set options($option) $newValue 1566 } 1567 1568 -cursor { 1569 $widgets(frame) configure -cursor $newValue 1570 $widgets(entry) configure -cursor $newValue 1571 $widgets(listbox) configure -cursor $newValue 1572 set options($option) $newValue 1573 } 1574 1575 -disabledforeground { 1576 set updateVisual 1 1577 set options($option) $newValue 1578 } 1579 1580 -disabledbackground { 1581 set updateVisual 1 1582 set options($option) $newValue 1583 } 1584 1585 -dropdownwidth { 1586 set options($option) $newValue 1587 } 1588 1589 -editable { 1590 set updateVisual 1 1591 if {$newValue} { 1592 # it's editable... 1593 $widgets(entry) configure \ 1594 -state normal \ 1595 -cursor $defaultEntryCursor 1596 } else { 1597 $widgets(entry) configure \ 1598 -state disabled \ 1599 -cursor $options(-cursor) 1600 } 1601 set options($option) $newValue 1602 } 1603 1604 -font { 1605 $widgets(entry) configure -font $newValue 1606 $widgets(listbox) configure -font $newValue 1607 set options($option) $newValue 1608 } 1609 1610 -foreground { 1611 set updateVisual 1 1612 set options($option) $newValue 1613 } 1614 1615 -height { 1616 $widgets(listbox) configure -height $newValue 1617 HandleScrollbar $w 1618 set options($option) $newValue 1619 } 1620 1621 -highlightbackground { 1622 $widgets(frame) configure -highlightbackground $newValue 1623 set options($option) $newValue 1624 } 1625 1626 -highlightcolor { 1627 $widgets(frame) configure -highlightcolor $newValue 1628 set options($option) $newValue 1629 } 1630 1631 -highlightthickness { 1632 $widgets(frame) configure -highlightthickness $newValue 1633 set options($option) $newValue 1634 } 1635 1636 -image { 1637 if {[string length $newValue] > 0} { 1638 $widgets(button) configure -image $newValue 1639 } else { 1640 $widgets(button) configure -image ::combobox::bimage 1641 } 1642 set options($option) $newValue 1643 } 1644 1645 -maxheight { 1646 # ComputeGeometry may dork with the actual height 1647 # of the listbox, so let's undork it 1648 $widgets(listbox) configure -height $options(-height) 1649 HandleScrollbar $w 1650 set options($option) $newValue 1651 } 1652 1653 -opencommand { 1654 # nothing else to do... 1655 set options($option) $newValue 1656 } 1657 1658 -relief { 1659 $widgets(frame) configure -relief $newValue 1660 set options($option) $newValue 1661 } 1662 1663 -selectbackground { 1664 $widgets(entry) configure -selectbackground $newValue 1665 $widgets(listbox) configure -selectbackground $newValue 1666 set options($option) $newValue 1667 } 1668 1669 -selectborderwidth { 1670 $widgets(entry) configure -selectborderwidth $newValue 1671 $widgets(listbox) configure -selectborderwidth $newValue 1672 set options($option) $newValue 1673 } 1674 1675 -selectforeground { 1676 $widgets(entry) configure -selectforeground $newValue 1677 $widgets(listbox) configure -selectforeground $newValue 1678 set options($option) $newValue 1679 } 1680 1681 -state { 1682 if {$newValue == "normal"} { 1683 set updateVisual 1 1684 # it's enabled 1685 1686 set editable [::combobox::GetBoolean \ 1687 $options(-editable)] 1688 if {$editable} { 1689 $widgets(entry) configure -state normal 1690 $widgets(entry) configure -takefocus 1 1691 } 1692 1693 # note that $widgets(button) is actually a label, 1694 # not a button. And being able to disable labels 1695 # wasn't possible until tk 8.3. (makes me wonder 1696 # why I chose to use a label, but that answer is 1697 # lost to antiquity) 1698 if {[info patchlevel] >= 8.3} { 1699 $widgets(button) configure -state normal 1700 } 1701 1702 } elseif {$newValue == "disabled"} { 1703 set updateVisual 1 1704 # it's disabled 1705 $widgets(entry) configure -state disabled 1706 $widgets(entry) configure -takefocus 0 1707 # note that $widgets(button) is actually a label, 1708 # not a button. And being able to disable labels 1709 # wasn't possible until tk 8.3. (makes me wonder 1710 # why I chose to use a label, but that answer is 1711 # lost to antiquity) 1712 if {$::tcl_version >= 8.3} { 1713 $widgets(button) configure -state disabled 1714 } 1715 1716 } else { 1717 set options($option) $oldValue 1718 set message "bad state value \"$newValue\";" 1719 append message " must be normal or disabled" 1720 error $message 1721 } 1722 1723 set options($option) $newValue 1724 } 1725 1726 -takefocus { 1727 $widgets(entry) configure -takefocus $newValue 1728 set options($option) $newValue 1729 } 1730 1731 -textvariable { 1732 $widgets(entry) configure -textvariable $newValue 1733 set options($option) $newValue 1734 } 1735 1736 -value { 1737 ::combobox::SetValue $widgets(this) $newValue 1738 set options($option) $newValue 1739 } 1740 1741 -width { 1742 $widgets(entry) configure -width $newValue 1743 $widgets(listbox) configure -width $newValue 1744 set options($option) $newValue 1745 } 1746 1747 -xscrollcommand { 1748 $widgets(entry) configure -xscrollcommand $newValue 1749 set options($option) $newValue 1750 } 1751 } 1752 1753 if {$updateVisual} {UpdateVisualAttributes $w} 1754 } 1755 } 1756 1757 # ::combobox::UpdateVisualAttributes -- 1758 # 1759 # sets the visual attributes (foreground, background mostly) 1760 # based on the current state of the widget (normal/disabled, 1761 # editable/non-editable) 1762 # 1763 # why a proc for such a simple thing? Well, in addition to the 1764 # various states of the widget, we also have to consider the 1765 # version of tk being used -- versions from 8.4 and beyond have 1766 # the notion of disabled foreground/background options for various 1767 # widgets. All of the permutations can get nasty, so we encapsulate 1768 # it all in one spot. 1769 # 1770 # note also that we don't handle all visual attributes here; just 1771 # the ones that depend on the state of the widget. The rest are 1772 # handled on a case by case basis 1773 # 1774 # Arguments: 1775 # w widget pathname 1776 # 1777 # Returns: 1778 # empty string 1779 1780 proc ::combobox::UpdateVisualAttributes {w} { 1781 1782 upvar ::combobox::${w}::widgets widgets 1783 upvar ::combobox::${w}::options options 1784 1785 if {$options(-state) == "normal"} { 1786 1787 set foreground $options(-foreground) 1788 set background $options(-background) 1789 1790 } elseif {$options(-state) == "disabled"} { 1791 1792 set foreground $options(-disabledforeground) 1793 set background $options(-disabledbackground) 1794 } 1795 1796 $widgets(entry) configure -foreground $foreground -background $background 1797 $widgets(listbox) configure -foreground $foreground -background $background 1798 $widgets(button) configure -foreground $foreground 1799 $widgets(frame) configure -background $background 1800 1801 # we need to set the disabled colors in case our widget is disabled. 1802 # We could actually check for disabled-ness, but we also need to 1803 # check whether we're enabled but not editable, in which case the 1804 # entry widget is disabled but we still want the enabled colors. It's 1805 # easier just to set everything and be done with it. 1806 1807 if {$::tcl_version >= 8.4} { 1808 $widgets(entry) configure \ 1809 -disabledforeground $foreground \ 1810 -disabledbackground $background 1811 $widgets(button) configure -disabledforeground $foreground 1812 $widgets(listbox) configure -disabledforeground $foreground 1813 } 1814 } 1815 1816 # ::combobox::SetValue -- 1817 # 1818 # sets the value of the combobox and calls the -command, 1819 # if defined 1820 # 1821 # Arguments: 1822 # 1823 # w widget pathname 1824 # newValue the new value of the combobox 1825 # 1826 # Returns 1827 # 1828 # Empty string 1829 1830 proc ::combobox::SetValue {w newValue} { 1831 1832 upvar ::combobox::${w}::widgets widgets 1833 upvar ::combobox::${w}::options options 1834 upvar ::combobox::${w}::ignoreTrace ignoreTrace 1835 upvar ::combobox::${w}::oldValue oldValue 1836 1837 if {[info exists options(-textvariable)] \ 1838 && [string length $options(-textvariable)] > 0} { 1839 set variable ::$options(-textvariable) 1840 set $variable $newValue 1841 } else { 1842 set oldstate [$widgets(entry) cget -state] 1843 $widgets(entry) configure -state normal 1844 $widgets(entry) delete 0 end 1845 $widgets(entry) insert 0 $newValue 1846 $widgets(entry) configure -state $oldstate 1847 } 1848 1849 # set our internal textvariable; this will cause any public 1850 # textvariable (ie: defined by the user) to be updated as 1851 # well 1852 # set ::combobox::${w}::entryTextVariable $newValue 1853 1854 # redefine our concept of the "old value". Do it before running 1855 # any associated command so we can be sure it happens even 1856 # if the command somehow fails. 1857 set oldValue $newValue 1858 1859 1860 # call the associated command. The proc will handle whether or 1861 # not to actually call it, and with what args 1862 CallCommand $w $newValue 1863 1864 return "" 1865 } 1866 1867 # ::combobox::CallCommand -- 1868 # 1869 # calls the associated command, if any, appending the new 1870 # value to the command to be called. 1871 # 1872 # Arguments: 1873 # 1874 # w widget pathname 1875 # newValue the new value of the combobox 1876 # 1877 # Returns 1878 # 1879 # empty string 1880 1881 proc ::combobox::CallCommand {w newValue} { 1882 upvar ::combobox::${w}::widgets widgets 1883 upvar ::combobox::${w}::options options 1884 1885 # call the associated command, if defined and -commandstate is 1886 # set to "normal" 1887 if {$options(-commandstate) == "normal" && \ 1888 [string length $options(-command)] > 0} { 1889 set args [list $widgets(this) $newValue] 1890 uplevel \#0 $options(-command) $args 1891 } 1892 } 1893 1894 1895 # ::combobox::GetBoolean -- 1896 # 1897 # returns the value of a (presumably) boolean string (ie: it should 1898 # do the right thing if the string is "yes", "no", "true", 1, etc 1899 # 1900 # Arguments: 1901 # 1902 # value value to be converted 1903 # errorValue a default value to be returned in case of an error 1904 # 1905 # Returns: 1906 # 1907 # a 1 or zero, or the value of errorValue if the string isn't 1908 # a proper boolean value 1909 1910 proc ::combobox::GetBoolean {value {errorValue 1}} { 1911 if {[catch {expr {([string trim $value])?1:0}} res]} { 1912 return $errorValue 1913 } else { 1914 return $res 1915 } 1916 } 1917 1918 # ::combobox::convert -- 1919 # 1920 # public routine to convert %x, %y and %W binding substitutions. 1921 # Given an x, y and or %W value relative to a given widget, this 1922 # routine will convert the values to be relative to the combobox 1923 # widget. For example, it could be used in a binding like this: 1924 # 1925 # bind .combobox <blah> {doSomething [::combobox::convert %W -x %x]} 1926 # 1927 # Note that this procedure is *not* exported, but is intended for 1928 # public use. It is not exported because the name could easily 1929 # clash with existing commands. 1930 # 1931 # Arguments: 1932 # 1933 # w a widget path; typically the actual result of a %W 1934 # substitution in a binding. It should be either a 1935 # combobox widget or one of its subwidgets 1936 # 1937 # args should one or more of the following arguments or 1938 # pairs of arguments: 1939 # 1940 # -x <x> will convert the value <x>; typically <x> will 1941 # be the result of a %x substitution 1942 # -y <y> will convert the value <y>; typically <y> will 1943 # be the result of a %y substitution 1944 # -W (or -w) will return the name of the combobox widget 1945 # which is the parent of $w 1946 # 1947 # Returns: 1948 # 1949 # a list of the requested values. For example, a single -w will 1950 # result in a list of one items, the name of the combobox widget. 1951 # Supplying "-x 10 -y 20 -W" (in any order) will return a list of 1952 # three values: the converted x and y values, and the name of 1953 # the combobox widget. 1954 1955 proc ::combobox::convert {w args} { 1956 set result {} 1957 if {![winfo exists $w]} { 1958 error "window \"$w\" doesn't exist" 1959 } 1960 1961 while {[llength $args] > 0} { 1962 set option [lindex $args 0] 1963 set args [lrange $args 1 end] 1964 1965 switch -exact -- $option { 1966 -x { 1967 set value [lindex $args 0] 1968 set args [lrange $args 1 end] 1969 set win $w 1970 while {[winfo class $win] != "Combobox"} { 1971 incr value [winfo x $win] 1972 set win [winfo parent $win] 1973 if {$win == "."} break 1974 } 1975 lappend result $value 1976 } 1977 1978 -y { 1979 set value [lindex $args 0] 1980 set args [lrange $args 1 end] 1981 set win $w 1982 while {[winfo class $win] != "Combobox"} { 1983 incr value [winfo y $win] 1984 set win [winfo parent $win] 1985 if {$win == "."} break 1986 } 1987 lappend result $value 1988 } 1989 1990 -w - 1991 -W { 1992 set win $w 1993 while {[winfo class $win] != "Combobox"} { 1994 set win [winfo parent $win] 1995 if {$win == "."} break; 1996 } 1997 lappend result $win 1998 } 1999 } 2000 } 2001 return $result 2002 } 2003 2004 # ::combobox::Canonize -- 2005 # 2006 # takes a (possibly abbreviated) option or command name and either 2007 # returns the canonical name or an error 2008 # 2009 # Arguments: 2010 # 2011 # w widget pathname 2012 # object type of object to canonize; must be one of "command", 2013 # "option", "scan command" or "list command" 2014 # opt the option (or command) to be canonized 2015 # 2016 # Returns: 2017 # 2018 # Returns either the canonical form of an option or command, 2019 # or raises an error if the option or command is unknown or 2020 # ambiguous. 2021 2022 proc ::combobox::Canonize {w object opt} { 2023 variable widgetOptions 2024 variable columnOptions 2025 variable widgetCommands 2026 variable listCommands 2027 variable scanCommands 2028 2029 switch $object { 2030 command { 2031 if {[lsearch -exact $widgetCommands $opt] >= 0} { 2032 return $opt 2033 } 2034 2035 # command names aren't stored in an array, and there 2036 # isn't a way to get all the matches in a list, so 2037 # we'll stuff the commands in a temporary array so 2038 # we can use [array names] 2039 set list $widgetCommands 2040 foreach element $list { 2041 set tmp($element) "" 2042 } 2043 set matches [array names tmp ${opt}*] 2044 } 2045 2046 {list command} { 2047 if {[lsearch -exact $listCommands $opt] >= 0} { 2048 return $opt 2049 } 2050 2051 # command names aren't stored in an array, and there 2052 # isn't a way to get all the matches in a list, so 2053 # we'll stuff the commands in a temporary array so 2054 # we can use [array names] 2055 set list $listCommands 2056 foreach element $list { 2057 set tmp($element) "" 2058 } 2059 set matches [array names tmp ${opt}*] 2060 } 2061 2062 {scan command} { 2063 if {[lsearch -exact $scanCommands $opt] >= 0} { 2064 return $opt 2065 } 2066 2067 # command names aren't stored in an array, and there 2068 # isn't a way to get all the matches in a list, so 2069 # we'll stuff the commands in a temporary array so 2070 # we can use [array names] 2071 set list $scanCommands 2072 foreach element $list { 2073 set tmp($element) "" 2074 } 2075 set matches [array names tmp ${opt}*] 2076 } 2077 2078 option { 2079 if {[info exists widgetOptions($opt)] \ 2080 && [llength $widgetOptions($opt)] == 2} { 2081 return $opt 2082 } 2083 set list [array names widgetOptions] 2084 set matches [array names widgetOptions ${opt}*] 2085 } 2086 2087 } 2088 2089 if {[llength $matches] == 0} { 2090 set choices [HumanizeList $list] 2091 error "unknown $object \"$opt\"; must be one of $choices" 2092 2093 } elseif {[llength $matches] == 1} { 2094 set opt [lindex $matches 0] 2095 2096 # deal with option aliases 2097 switch $object { 2098 option { 2099 set opt [lindex $matches 0] 2100 if {[llength $widgetOptions($opt)] == 1} { 2101 set opt $widgetOptions($opt) 2102 } 2103 } 2104 } 2105 2106 return $opt 2107 2108 } else { 2109 set choices [HumanizeList $list] 2110 error "ambiguous $object \"$opt\"; must be one of $choices" 2111 } 2112 } 2113 2114 # ::combobox::HumanizeList -- 2115 # 2116 # Returns a human-readable form of a list by separating items 2117 # by columns, but separating the last two elements with "or" 2118 # (eg: foo, bar or baz) 2119 # 2120 # Arguments: 2121 # 2122 # list a valid tcl list 2123 # 2124 # Results: 2125 # 2126 # A string which as all of the elements joined with ", " or 2127 # the word " or " 2128 2129 proc ::combobox::HumanizeList {list} { 2130 2131 if {[llength $list] == 1} { 2132 return [lindex $list 0] 2133 } else { 2134 set list [lsort $list] 2135 set secondToLast [expr {[llength $list] -2}] 2136 set most [lrange $list 0 $secondToLast] 2137 set last [lindex $list end] 2138 2139 return "[join $most {, }] or $last" 2140 } 2141 } 2142 2143 # This is some backwards-compatibility code to handle TIP 44 2144 # (http://purl.org/tcl/tip/44.html). For all private tk commands 2145 # used by this widget, we'll make duplicates of the procs in the 2146 # combobox namespace. 2147 # 2148 # I'm not entirely convinced this is the right thing to do. I probably 2149 # shouldn't even be using the private commands. Then again, maybe the 2150 # private commands really should be public. Oh well; it works so it 2151 # must be OK... 2152 foreach command {TabToWindow CancelRepeat ListboxUpDown} { 2153 if {[llength [info commands ::combobox::tk$command]] == 1} break; 2154 2155 set tmp [info commands tk$command] 2156 set proc ::combobox::tk$command 2157 if {[llength [info commands tk$command]] == 1} { 2158 set command [namespace which [lindex $tmp 0]] 2159 proc $proc {args} "uplevel $command \$args" 2160 } else { 2161 if {[llength [info commands ::tk::$command]] == 1} { 2162 proc $proc {args} "uplevel ::tk::$command \$args" 2163 } 2164 } 2165 } 2166 2167 # end of combobox.tcl 2168