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