1 # Copyright (c) 1998-1999, Bryan Oakley
2 # All Rights Reservered
5 # oakley@channelpoint.com
7 # combobox v2.0b2 April 14, 1999
9 # a combobox / dropdown listbox (pick your favorite name) widget
12 # this code is freely distributable without restriction, but is
13 # provided as-is with no waranty expressed or implied.
15 # thanks to the following people who provided beta test support or
16 # patches to the code (in no particular order):
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
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
28 package require Tk 8.0
29 package provide combobox 2.0
31 namespace eval ::combobox {
33 # this is the public interface
34 namespace export combobox
36 # these contain references to available options
37 variable widgetOptions
39 # these contain references to available commands and subcommands
40 variable widgetCommands
46 # ::combobox::combobox --
48 # This is the command that gets exported. It creates a new
53 # w path of new widget to create
54 # args additional option/value pairs (eg: -background white, etc.)
58 # It creates the widget and sets up all of the default bindings
62 # The name of the newly create widget
64 proc ::combobox::combobox {w args} {
65 variable widgetOptions
66 variable widgetCommands
70 # perform a one time initialization
71 if {![info exists widgetOptions]} {
78 # set some bindings...
88 # Initialize the global (well, namespace) variables. This should
89 # only be called once, immediately prior to creating the first
90 # instance of the widget
98 # All state variables are set to their default values; all of
99 # the option database entries will exist.
105 proc ::combobox::Init {} {
106 variable widgetOptions
107 variable widgetCommands
108 variable scanCommands
109 variable listCommands
110 variable defaultEntryCursor
112 array set widgetOptions [list \
113 -background {background Background} \
116 -borderwidth {borderWidth BorderWidth} \
117 -command {command Command} \
118 -commandstate {commandState State} \
119 -cursor {cursor Cursor} \
120 -editable {editable Editable} \
123 -foreground {foreground Foreground} \
124 -height {height Height} \
125 -highlightbackground {highlightBackground HighlightBackground} \
126 -highlightcolor {highlightColor HighlightColor} \
127 -highlightthickness {highlightThickness HighlightThickness} \
128 -image {image Image} \
129 -maxheight {maxHeight Height} \
130 -relief {relief Relief} \
131 -selectbackground {selectBackground Foreground} \
132 -selectborderwidth {selectBorderWidth BorderWidth} \
133 -selectforeground {selectForeground Background} \
134 -state {state State} \
135 -takefocus {takeFocus TakeFocus} \
136 -textvariable {textVariable Variable} \
137 -value {value Value} \
138 -width {width Width} \
139 -xscrollcommand {xScrollCommand ScrollCommand} \
143 set widgetCommands [list \
144 bbox cget configure curselection \
145 delete get icursor index \
146 insert list scan selection \
147 xview select toggle open \
151 set listCommands [list \
156 set scanCommands [list mark dragto]
158 # why check for the Tk package? This lets us be sourced into
159 # an interpreter that doesn't have Tk loaded, such as the slave
160 # interpreter used by pkg_mkIndex. In theory it should have no
161 # side effects when run
162 if {[lsearch -exact [package names] "Tk"] != -1} {
164 ##################################################################
165 #- this initializes the option database. Kinda gross, but it works
167 ##################################################################
169 # the image used for the button...
170 if {$::tcl_platform(platform) == "windows"} {
171 image create bitmap ::combobox::bimage -data {
172 #define down_arrow_width 12
173 #define down_arrow_height 12
174 static char down_arrow_bits[] = {
175 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
176 0xfc,0xf1,0xf8,0xf0,0x70,0xf0,0x20,0xf0,
177 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00;
181 image create bitmap ::combobox::bimage -data {
182 #define down_arrow_width 15
183 #define down_arrow_height 15
184 static char down_arrow_bits[] = {
185 0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80,
186 0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83,
187 0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80,
188 0x00,0x80,0x00,0x80,0x00,0x80
193 # compute a widget name we can use to create a temporary widget
194 set tmpWidget ".__tmp__"
196 while {[winfo exists $tmpWidget] == 1} {
197 set tmpWidget ".__tmp__$count"
201 # get the scrollbar width. Because we try to be clever and draw our
202 # own button instead of using a tk widget, we need to know what size
203 # button to create. This little hack tells us the width of a scroll
206 # NB: we need to be sure and pick a window that doesn't already
209 set sb_width [winfo reqwidth $tmpWidget]
212 # steal options from the entry widget
213 # we want darn near all options, so we'll go ahead and do
214 # them all. No harm done in adding the one or two that we
217 foreach foo [$tmpWidget configure] {
218 # the cursor option is special, so we'll save it in
220 if {[lindex $foo 0] == "-cursor"} {
221 set defaultEntryCursor [lindex $foo 4]
223 if {[llength $foo] == 5} {
224 set option [lindex $foo 1]
225 set value [lindex $foo 4]
226 option add *Combobox.$option $value widgetDefault
228 # these options also apply to the dropdown listbox
229 if {[string compare $option "foreground"] == 0 \
230 || [string compare $option "background"] == 0 \
231 || [string compare $option "font"] == 0} {
232 option add *Combobox*ComboboxListbox.$option $value \
239 # these are unique to us...
240 option add *Combobox.cursor {}
241 option add *Combobox.commandState normal widgetDefault
242 option add *Combobox.editable 1 widgetDefault
243 option add *Combobox.maxHeight 10 widgetDefault
244 option add *Combobox.height 0
251 # ::combobox::SetClassBindings --
253 # Sets up the default bindings for the widget class
255 # this proc exists since it's The Right Thing To Do, but
256 # I haven't had the time to figure out how to do all the
257 # binding stuff on a class level. The main problem is that
258 # the entry widget must have focus for the insertion cursor
259 # to be visible. So, I either have to have the entry widget
260 # have the Combobox bindtag, or do some fancy juggling of
261 # events or some such. What a pain.
271 proc ::combobox::SetClassBindings {} {
273 # make sure we clean up after ourselves...
274 bind Combobox <Destroy> [list ::combobox::DestroyHandler %W]
276 # this will (hopefully) close (and lose the grab on) the
277 # listbox if the user clicks anywhere outside of it. Note
278 # that on Windows, you can click on some other app and
279 # the listbox will still be there, because tcl won't see
281 set this {[::combobox::convert %W -W]}
282 bind Combobox <Any-ButtonPress> "$this close"
283 bind Combobox <Any-ButtonRelease> "$this close"
285 # this helps (but doesn't fully solve) focus issues. The general
286 # idea is, whenever the frame gets focus it gets passed on to
288 bind Combobox <FocusIn> {tkTabToWindow [::combobox::convert %W -W].entry}
290 # this closes the listbox if we get hidden
291 bind Combobox <Unmap> {[::combobox::convert %W -W] close}
296 # ::combobox::SetBindings --
298 # here's where we do most of the binding foo. I think there's probably
299 # a few bindings I ought to add that I just haven't thought
302 # I'm not convinced these are the proper bindings. Ideally all
303 # bindings should be on "Combobox", but because of my juggling of
304 # bindtags I'm not convinced thats what I want to do. But, it all
305 # seems to work, its just not as robust as it could be.
315 proc ::combobox::SetBindings {w} {
316 upvar ::combobox::${w}::widgets widgets
317 upvar ::combobox::${w}::options options
319 # juggle the bindtags. The basic idea here is to associate the
320 # widget name with the entry widget, so if a user does a bind
321 # on the combobox it will get handled properly since it is
322 # the entry widget that has keyboard focus.
323 bindtags $widgets(entry) \
324 [concat $widgets(this) [bindtags $widgets(entry)]]
326 bindtags $widgets(button) \
327 [concat $widgets(this) [bindtags $widgets(button)]]
329 # override the default bindings for tab and shift-tab. The
330 # focus procs take a widget as their only parameter and we
331 # want to make sure the right window gets used (for shift-
332 # tab we want it to appear as if the event was generated
333 # on the frame rather than the entry. I
335 bind $widgets(entry) <Tab> \
336 "tkTabToWindow \[tk_focusNext $widgets(entry)\]; break"
337 bind $widgets(entry) <Shift-Tab> \
338 "tkTabToWindow \[tk_focusPrev $widgets(this)\]; break"
340 # this makes our "button" (which is actually a label)
342 bind $widgets(button) <ButtonPress-1> [list $widgets(this) toggle]
344 # this lets the autoscan of the listbox work, even if they
345 # move the cursor over the entry widget.
346 bind $widgets(entry) <B1-Enter> "break"
348 bind $widgets(listbox) <ButtonRelease-1> \
349 "::combobox::Select $widgets(this) \[$widgets(listbox) nearest %y\]; break"
351 bind $widgets(vsb) <ButtonPress-1> {continue}
352 bind $widgets(vsb) <ButtonRelease-1> {continue}
354 bind $widgets(listbox) <Any-Motion> {
355 %W selection clear 0 end
357 %W selection anchor @%x,%y
358 %W selection set @%x,%y @%x,%y
359 # need to do a yview if the cursor goes off the top
360 # or bottom of the window... (or do we?)
363 # these events need to be passed from the entry
364 # widget to the listbox, or need some sort of special
366 foreach event [list <Up> <Down> <Tab> <Return> <Escape> \
367 <Next> <Prior> <Double-1> <1> <Any-KeyPress> \
368 <FocusIn> <FocusOut>] {
369 bind $widgets(entry) $event \
370 "::combobox::HandleEvent $widgets(this) $event"
375 # ::combobox::Build --
377 # This does all of the work necessary to create the basic
383 # args additional option/value pairs
387 # Creates a new widget with the given name. Also creates a new
388 # namespace patterened after the widget name, as a child namespace
393 # the name of the widget
395 proc ::combobox::Build {w args } {
396 variable widgetOptions
398 if {[winfo exists $w]} {
399 error "window name \"$w\" already exists"
402 # create the namespace for this instance, and define a few
404 namespace eval ::combobox::$w {
406 variable ignoreTrace 0
414 set widgets(foo) foo ;# coerce into an array
415 set options(foo) foo ;# coerce into an array
421 # import the widgets and options arrays into this proc so
422 # we don't have to use fully qualified names, which is a
424 upvar ::combobox::${w}::widgets widgets
425 upvar ::combobox::${w}::options options
427 # this is our widget -- a frame of class Combobox. Naturally,
428 # it will contain other widgets. We create it here because
429 # we need it to be able to set our default options.
430 set widgets(this) [frame $w -class Combobox -takefocus 0]
431 set widgets(entry) [entry $w.entry -takefocus 1]
432 set widgets(button) [label $w.button -takefocus 0]
434 # this defines all of the default options. We get the
435 # values from the option database. Note that if an array
436 # value is a list of length one it is an alias to another
437 # option, so we just ignore it
438 foreach name [array names widgetOptions] {
439 if {[llength $widgetOptions($name)] == 1} continue
440 set optName [lindex $widgetOptions($name) 0]
441 set optClass [lindex $widgetOptions($name) 1]
442 set value [option get $w $optName $optClass]
443 set options($name) $value
446 # if -value is set to null, we'll remove it from our
447 # local array. The assumption is, if the user sets it from
448 # the option database, they will set it to something other
449 # than null (since it's impossible to determine the difference
450 # between a null value and no value at all).
451 if {[info exists options(-value)] \
452 && [string length $options(-value)] == 0} {
453 unset options(-value)
456 # we will later rename the frame's widget proc to be our
457 # own custom widget proc. We need to keep track of this
458 # new name, so we'll define and store it here...
459 set widgets(frame) ::combobox::${w}::$w
461 # gotta do this sooner or later. Might as well do it now
462 pack $widgets(entry) -side left -fill both -expand yes
463 pack $widgets(button) -side right -fill y -expand no
465 # I should probably do this in a catch, but for now it's
466 # good enough... What it does, obviously, is put all of
467 # the option/values pairs into an array. Make them easier
468 # to handle later on...
469 array set options $args
471 # now, the dropdown list... the same renaming nonsense
472 # must go on here as well...
473 set widgets(popup) [toplevel $w.top]
474 set widgets(listbox) [listbox $w.top.list]
475 set widgets(vsb) [scrollbar $w.top.vsb]
477 pack $widgets(listbox) -side left -fill both -expand y
479 # fine tune the widgets based on the options (and a few
480 # arbitrary values...)
482 # NB: we are going to use the frame to handle the relief
483 # of the widget as a whole, so the entry widget will be
484 # flat. This makes the button which drops down the list
485 # to appear "inside" the entry widget.
487 $widgets(vsb) configure \
488 -command "$widgets(listbox) yview" \
489 -highlightthickness 0
491 $widgets(button) configure \
492 -highlightthickness 0 \
495 -width [expr {[winfo reqwidth $widgets(vsb)] - 2}]
497 $widgets(entry) configure \
500 -highlightthickness 0
502 $widgets(popup) configure \
506 $widgets(listbox) configure \
508 -background [$widgets(entry) cget -bg] \
509 -yscrollcommand "$widgets(vsb) set" \
510 -exportselection false \
514 # trace variable ::combobox::${w}::entryTextVariable w \
515 # [list ::combobox::EntryTrace $w]
517 # do some window management foo on the dropdown window
518 wm overrideredirect $widgets(popup) 1
519 wm transient $widgets(popup) [winfo toplevel $w]
520 wm group $widgets(popup) [winfo parent $w]
521 wm resizable $widgets(popup) 0 0
522 wm withdraw $widgets(popup)
524 # this moves the original frame widget proc into our
525 # namespace and gives it a handy name
526 rename ::$w $widgets(frame)
528 # now, create our widget proc. Obviously (?) it goes in
529 # the global namespace. All combobox widgets will actually
530 # share the same widget proc to cut down on the amount of
532 proc ::$w {command args} \
533 "eval ::combobox::WidgetProc $w \$command \$args"
536 # ok, the thing exists... let's do a bit more configuration.
537 if {[catch "::combobox::Configure $widgets(this) [array get options]" error]} {
546 # ::combobox::HandleEvent --
548 # this proc handles events from the entry widget that we want
549 # handled specially (typically, to allow navigation of the list
550 # even though the focus is in the entry widget)
555 # event a string representing the event (not necessarily an
558 proc ::combobox::HandleEvent {w event} {
559 upvar ::combobox::${w}::widgets widgets
560 upvar ::combobox::${w}::options options
561 upvar ::combobox::${w}::oldValue oldValue
563 # for all of these events, if we have a special action we'll
564 # do that and do a "return -code break" to keep additional
565 # bindings from firing. Otherwise we'll let the event fall
570 # if the widget is editable, clear the selection.
571 # this makes it more obvious what will happen if the
572 # user presses <Return> (and helps our code know what
573 # to do if the user presses return)
574 if {$options(-editable)} {
575 $widgets(listbox) see 0
576 $widgets(listbox) selection clear 0 end
577 $widgets(listbox) selection anchor 0
578 $widgets(listbox) activate 0
583 set oldValue [$widgets(entry) get]
587 if {![winfo ismapped $widgets(popup)]} {
588 # did the value change?
589 # set newValue [set ::combobox::${w}::entryTextVariable]
590 set newValue [$widgets(entry) get]
591 if {$oldValue != $newValue} {
592 CallCommand $widgets(this) $newValue
598 set editable [::combobox::GetBoolean $options(-editable)]
600 if {[winfo ismapped $widgets(popup)]} {
605 if {$options(-state) != "disabled"} {
614 if {$options(-state) != "disabled"} {
615 $widgets(this) toggle
621 if {[winfo ismapped $widgets(popup)]} {
622 ::combobox::Find $widgets(this) 0
625 ::combobox::SetValue $widgets(this) [$widgets(this) get]
630 # $widgets(entry) delete 0 end
631 # $widgets(entry) insert 0 $oldValue
632 if {[winfo ismapped $widgets(popup)]} {
639 # did the value change?
640 # set newValue [set ::combobox::${w}::entryTextVariable]
641 set newValue [$widgets(entry) get]
642 if {$oldValue != $newValue} {
643 CallCommand $widgets(this) $newValue
646 if {[winfo ismapped $widgets(popup)]} {
647 ::combobox::Select $widgets(this) \
648 [$widgets(listbox) curselection]
655 $widgets(listbox) yview scroll 1 pages
656 set index [$widgets(listbox) index @0,0]
657 $widgets(listbox) see $index
658 $widgets(listbox) activate $index
659 $widgets(listbox) selection clear 0 end
660 $widgets(listbox) selection anchor $index
661 $widgets(listbox) selection set $index
666 $widgets(listbox) yview scroll -1 pages
667 set index [$widgets(listbox) index @0,0]
668 $widgets(listbox) activate $index
669 $widgets(listbox) see $index
670 $widgets(listbox) selection clear 0 end
671 $widgets(listbox) selection anchor $index
672 $widgets(listbox) selection set $index
676 if {[winfo ismapped $widgets(popup)]} {
677 tkListboxUpDown $widgets(listbox) 1
681 if {$options(-state) != "disabled"} {
688 if {[winfo ismapped $widgets(popup)]} {
689 tkListboxUpDown $widgets(listbox) -1
693 if {$options(-state) != "disabled"} {
704 # ::combobox::DestroyHandler {w} --
706 # Cleans up after a combobox widget is destroyed
714 # The namespace that was created for the widget is deleted,
715 # and the widget proc is removed.
717 proc ::combobox::DestroyHandler {w} {
719 # if the widget actually being destroyed is of class Combobox,
720 # crush the namespace and kill the proc. Get it? Crush. Kill.
721 # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it
722 # brings tears to my eyes.
723 if {[string compare [winfo class $w] "Combobox"] == 0} {
724 upvar ::combobox::${w}::widgets widgets
725 upvar ::combobox::${w}::options options
727 # delete the namespace and the proc which represents
729 namespace delete ::combobox::$w
738 # finds something in the listbox that matches the pattern in the
739 # entry widget and selects it
741 # N.B. I'm not convinced this is working the way it ought to. It
742 # works, but is the behavior what is expected? I've also got a gut
743 # feeling that there's a better way to do this, but I'm too lazy to
749 # exact boolean; if true an exact match is desired
755 proc ::combobox::Find {w {exact 0}} {
756 upvar ::combobox::${w}::widgets widgets
757 upvar ::combobox::${w}::options options
759 ## *sigh* this logic is rather gross and convoluted. Surely
760 ## there is a more simple, straight-forward way to implement
761 ## all this. As the saying goes, I lack the time to make it
764 # use what is already in the entry widget as a pattern
765 set pattern [$widgets(entry) get]
767 if {[string length $pattern] == 0} {
768 # clear the current selection
769 $widgets(listbox) see 0
770 $widgets(listbox) selection clear 0 end
771 $widgets(listbox) selection anchor 0
772 $widgets(listbox) activate 0
776 # we're going to be searching this list...
777 set list [$widgets(listbox) get 0 end]
779 # if we are doing an exact match, try to find,
780 # well, an exact match
783 set exactMatch [lsearch -exact $list $pattern]
786 # search for it. We'll try to be clever and not only
787 # search for a match for what they typed, but a match for
788 # something close to what they typed. We'll keep removing one
789 # character at a time from the pattern until we find a match
792 while {$index == -1 && [string length $pattern]} {
793 set index [lsearch -glob $list "$pattern*"]
795 regsub {.$} $pattern {} pattern
799 # this is the item that most closely matches...
800 set thisItem [lindex $list $index]
802 # did we find a match? If so, do some additional munging...
805 # we need to find the part of the first item that is
806 # unique WRT the second... I know there's probably a
807 # simpler way to do this...
809 set nextIndex [expr {$index + 1}]
810 set nextItem [lindex $list $nextIndex]
812 # we don't really need to do much if the next
813 # item doesn't match our pattern...
814 if {[string match $pattern* $nextItem]} {
815 # ok, the next item matches our pattern, too
816 # now the trick is to find the first character
817 # where they *don't* match...
818 set marker [string length $pattern]
819 while {$marker <= [string length $pattern]} {
820 set a [string index $thisItem $marker]
821 set b [string index $nextItem $marker]
822 if {[string compare $a $b] == 0} {
830 set marker [string length $pattern]
838 # ok, we know the pattern and what part is unique;
839 # update the entry widget and listbox appropriately
840 if {$exact && $exactMatch == -1} {
841 # this means we didn't find an exact match
842 $widgets(listbox) selection clear 0 end
843 $widgets(listbox) see $index
846 # this means we found something, but it isn't an exact
847 # match. If we find something that *is* an exact match we
848 # don't need to do the following, since it would merely
849 # be replacing the data in the entry widget with itself
850 set oldstate [$widgets(entry) cget -state]
851 $widgets(entry) configure -state normal
852 $widgets(entry) delete 0 end
853 $widgets(entry) insert end $thisItem
854 $widgets(entry) selection clear
855 $widgets(entry) selection range $marker end
856 $widgets(listbox) activate $index
857 $widgets(listbox) selection clear 0 end
858 $widgets(listbox) selection anchor $index
859 $widgets(listbox) selection set $index
860 $widgets(listbox) see $index
861 $widgets(entry) configure -state $oldstate
865 # ::combobox::Select --
867 # selects an item from the list and sets the value of the combobox
873 # index listbox index of item to be selected
879 proc ::combobox::Select {w index} {
880 upvar ::combobox::${w}::widgets widgets
881 upvar ::combobox::${w}::options options
884 set data [$widgets(listbox) get [lindex $index 0]]
885 ::combobox::SetValue $widgets(this) $data
887 $widgets(listbox) selection clear 0 end
888 $widgets(listbox) selection anchor $index
889 $widgets(listbox) selection set $index
891 $widgets(entry) selection range 0 end
899 # ::combobox::HandleScrollbar --
901 # causes the scrollbar of the dropdown list to appear or disappear
902 # based on the contents of the dropdown listbox
907 # action the action to perform on the scrollbar
913 proc ::combobox::HandleScrollbar {w {action "unknown"}} {
914 upvar ::combobox::${w}::widgets widgets
915 upvar ::combobox::${w}::options options
917 if {$options(-height) == 0} {
918 set hlimit $options(-maxheight)
920 set hlimit $options(-height)
925 if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} {
926 pack $widgets(vsb) -side right -fill y -expand n
931 if {$hlimit > 0 && [$widgets(listbox) size] <= $hlimit} {
932 pack forget $widgets(vsb)
937 # this means the window was cropped and we definitely
938 # need a scrollbar no matter what the user wants
939 pack $widgets(vsb) -side right -fill y -expand n
943 if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} {
944 pack $widgets(vsb) -side right -fill y -expand n
946 pack forget $widgets(vsb)
954 # ::combobox::ComputeGeometry --
956 # computes the geometry of the popup list based on the size of the
965 # the desired geometry of the listbox
967 proc ::combobox::ComputeGeometry {w} {
968 upvar ::combobox::${w}::widgets widgets
969 upvar ::combobox::${w}::options options
971 if {$options(-height) == 0 && $options(-maxheight) != "0"} {
972 # if this is the case, count the items and see if
973 # it exceeds our maxheight. If so, set the listbox
974 # size to maxheight...
975 set nitems [$widgets(listbox) size]
976 if {$nitems > $options(-maxheight)} {
977 # tweak the height of the listbox
978 $widgets(listbox) configure -height $options(-maxheight)
980 # un-tweak the height of the listbox
981 $widgets(listbox) configure -height 0
986 # compute height and width of the dropdown list
987 set bd [$widgets(popup) cget -borderwidth]
988 set height [expr {[winfo reqheight $widgets(popup)] + $bd + $bd}]
989 set width [winfo width $widgets(this)]
991 # figure out where to place it on the screen, trying to take into
992 # account we may be running under some virtual window manager
993 set screenWidth [winfo screenwidth $widgets(this)]
994 set screenHeight [winfo screenheight $widgets(this)]
995 set rootx [winfo rootx $widgets(this)]
996 set rooty [winfo rooty $widgets(this)]
997 set vrootx [winfo vrootx $widgets(this)]
998 set vrooty [winfo vrooty $widgets(this)]
1000 # the x coordinate is simply the rootx of our widget, adjusted for
1001 # the virtual window. We won't worry about whether the window will
1002 # be offscreen to the left or right -- we want the illusion that it
1003 # is part of the entry widget, so if part of the entry widget is off-
1004 # screen, so will the list. If you want to change the behavior,
1005 # simply change the if statement... (and be sure to update this
1007 set x [expr {$rootx + $vrootx}]
1009 set rightEdge [expr {$x + $width}]
1010 if {$rightEdge > $screenWidth} {
1011 set x [expr {$screenWidth - $width}]
1013 if {$x < 0} {set x 0}
1016 # the y coordinate is the rooty plus vrooty offset plus
1017 # the height of the static part of the widget plus 1 for a
1018 # tiny bit of visual separation...
1019 set y [expr {$rooty + $vrooty + [winfo reqheight $widgets(this)] + 1}]
1020 set bottomEdge [expr {$y + $height}]
1022 if {$bottomEdge >= $screenHeight} {
1023 # ok. Fine. Pop it up above the entry widget isntead of
1025 set y [expr {($rooty - $height - 1) + $vrooty}]
1028 # this means it extends beyond our screen. How annoying.
1029 # Now we'll try to be real clever and either pop it up or
1030 # down, depending on which way gives us the biggest list.
1031 # then, we'll trim the list to fit and force the use of
1034 # (sadly, for windows users this measurement doesn't
1035 # take into consideration the height of the taskbar,
1036 # but don't blame me -- there isn't any way to detect
1037 # it or figure out its dimensions. The same probably
1038 # applies to any window manager with some magic windows
1039 # glued to the top or bottom of the screen)
1041 if {$rooty > [expr {$screenHeight / 2}]} {
1042 # we are in the lower half of the screen --
1043 # pop it up. Y is zero; that parts easy. The height
1044 # is simply the y coordinate of our widget, minus
1045 # a pixel for some visual separation. The y coordinate
1046 # will be the topof the screen.
1048 set height [expr {$rooty - 1 - $y}]
1051 # we are in the upper half of the screen --
1053 set y [expr {$rooty + $vrooty + \
1054 [winfo reqheight $widgets(this)] + 1}]
1055 set height [expr {$screenHeight - $y}]
1060 HandleScrollbar $widgets(this) crop
1067 set height $screenheight
1070 set geometry [format "=%dx%d+%d+%d" $width $height $x $y]
1075 # ::combobox::DoInternalWidgetCommand --
1077 # perform an internal widget command, then mung any error results
1078 # to look like it came from our megawidget. A lot of work just to
1079 # give the illusion that our megawidget is an atomic widget
1084 # subwidget pathname of the subwidget
1085 # command subwidget command to be executed
1086 # args arguments to the command
1090 # The result of the subwidget command, or an error
1092 proc ::combobox::DoInternalWidgetCommand {w subwidget command args} {
1093 upvar ::combobox::${w}::widgets widgets
1094 upvar ::combobox::${w}::options options
1096 set subcommand $command
1097 set command [concat $widgets($subwidget) $command $args]
1098 if {[catch $command result]} {
1099 # replace the subwidget name with the megawidget name
1100 regsub $widgets($subwidget) $result $widgets(this) result
1102 # replace specific instances of the subwidget command
1103 # with out megawidget command
1104 switch $subwidget,$subcommand {
1105 listbox,index {regsub "index" $result "list index" result}
1106 listbox,insert {regsub "insert" $result "list insert" result}
1107 listbox,delete {regsub "delete" $result "list delete" result}
1108 listbox,get {regsub "get" $result "list get" result}
1109 listbox,size {regsub "size" $result "list size" result}
1119 # ::combobox::WidgetProc --
1121 # This gets uses as the widgetproc for an combobox widget.
1122 # Notice where the widget is created and you'll see that the
1123 # actual widget proc merely evals this proc with all of the
1126 # Note that some widget commands are defined "inline" (ie:
1127 # within this proc), and some do most of their work in
1128 # separate procs. This is merely because sometimes it was
1129 # easier to do it one way or the other.
1134 # command widget subcommand
1135 # args additional arguments; varies with the subcommand
1139 # Performs the requested widget command
1141 proc ::combobox::WidgetProc {w command args} {
1142 upvar ::combobox::${w}::widgets widgets
1143 upvar ::combobox::${w}::options options
1144 upvar ::combobox::${w}::oldFocus oldFocus
1145 upvar ::combobox::${w}::oldFocus oldGrab
1147 set command [::combobox::Canonize $w command $command]
1149 # this is just shorthand notation...
1150 set doWidgetCommand \
1151 [list ::combobox::DoInternalWidgetCommand $widgets(this)]
1153 if {$command == "list"} {
1154 # ok, the next argument is a list command; we'll
1155 # rip it from args and append it to command to
1156 # create a unique internal command
1158 # NB: because of the sloppy way we are doing this,
1159 # we'll also let the user enter our secret command
1160 # directly (eg: listinsert, listdelete), but we
1161 # won't document that fact
1162 set command "list-[lindex $args 0]"
1163 set args [lrange $args 1 end]
1168 # many of these commands are just synonyms for specific
1169 # commands in one of the subwidgets. We'll get them out
1170 # of the way first, then do the custom commands.
1181 set result [eval $doWidgetCommand entry $command $args]
1183 list-get {set result [eval $doWidgetCommand listbox get $args]}
1184 list-index {set result [eval $doWidgetCommand listbox index $args]}
1185 list-size {set result [eval $doWidgetCommand listbox size $args]}
1188 if {[llength $args] == 1} {
1189 set index [lindex $args 0]
1190 set result [Select $widgets(this) $index]
1192 error "usage: $w select index"
1197 set knownWidgets [list button entry listbox popup vsb]
1198 if {[llength $args] == 0} {
1199 return $knownWidgets
1202 set name [lindex $args 0]
1203 if {[lsearch $knownWidgets $name] != -1} {
1204 set result $widgets($name)
1206 error "unknown subwidget $name"
1211 set result [eval $doWidgetCommand listbox curselection]
1215 eval $doWidgetCommand listbox insert $args
1216 set result [HandleScrollbar $w "grow"]
1220 eval $doWidgetCommand listbox delete $args
1221 set result [HandleScrollbar $w "shrink"]
1225 # ignore this command if the widget is disabled...
1226 if {$options(-state) == "disabled"} return
1228 # pops down the list if it is not, hides it
1230 if {[winfo ismapped $widgets(popup)]} {
1231 set result [$widgets(this) close]
1233 set result [$widgets(this) open]
1239 # if this is an editable combobox, the focus should
1240 # be set to the entry widget
1241 if {$options(-editable)} {
1242 focus $widgets(entry)
1243 $widgets(entry) select range 0 end
1244 $widgets(entry) icur end
1247 # if we are disabled, we won't allow this to happen
1248 if {$options(-state) == "disabled"} {
1252 # compute the geometry of the window to pop up, and set
1253 # it, and force the window manager to take notice
1254 # (even if it is not presently visible).
1256 # this isn't strictly necessary if the window is already
1257 # mapped, but we'll go ahead and set the geometry here
1258 # since its harmless and *may* actually reset the geometry
1259 # to something better in some weird case.
1260 set geometry [::combobox::ComputeGeometry $widgets(this)]
1261 wm geometry $widgets(popup) $geometry
1264 # if we are already open, there's nothing else to do
1265 if {[winfo ismapped $widgets(popup)]} {
1269 # save the widget that currently has the focus; we'll restore
1270 # the focus there when we're done
1271 set oldFocus [focus]
1273 # ok, tweak the visual appearance of things and
1274 # make the list pop up
1275 $widgets(button) configure -relief sunken
1276 raise $widgets(popup) [winfo parent $widgets(this)]
1277 wm deiconify $widgets(popup)
1279 # force focus to the entry widget so we can handle keypress
1280 # events for traversal
1281 focus -force $widgets(entry)
1283 # select something by default, but only if its an
1285 ::combobox::Find $widgets(this) 1
1287 # save the current grab state for the display containing
1288 # this widget. We'll restore it when we close the dropdown
1291 set grab [grab current $widgets(this)]
1292 if {$grab != ""} {set status [grab status $grab]}
1293 set oldGrab [list $grab $status]
1296 # *gasp* do a global grab!!! Mom always told not to
1297 # do things like this, but these are desparate times.
1298 grab -global $widgets(this)
1300 # fake the listbox into thinking it has focus. This is
1301 # necessary to get scanning initialized properly in the
1303 event generate $widgets(listbox) <B1-Enter>
1309 # if we are already closed, don't do anything...
1310 if {![winfo ismapped $widgets(popup)]} {
1314 # restore the focus and grab, but ignore any errors...
1315 # we're going to be paranoid and release the grab before
1316 # trying to set any other grab because we really really
1317 # really want to make sure the grab is released.
1318 catch {focus $oldFocus} result
1319 catch {grab release $widgets(this)}
1321 set status [lindex $oldGrab 1]
1322 if {$status == "global"} {
1323 grab -global [lindex $oldGrab 0]
1324 } elseif {$status == "local"} {
1325 grab [lindex $oldGrab 0]
1331 $widgets(button) configure -relief raised
1332 wm withdraw $widgets(popup)
1334 # select the data in the entry widget. Not sure
1335 # why, other than observation seems to suggest that's
1336 # what windows widgets do.
1337 set editable [::combobox::GetBoolean $options(-editable)]
1339 $widgets(entry) selection range 0 end
1340 $widgets(button) configure -relief raised
1344 # magic tcl stuff (see tk.tcl in the distribution
1352 if {[llength $args] != 1} {
1353 error "wrong # args: should be $w cget option"
1355 set opt [::combobox::Canonize $w option [lindex $args 0]]
1357 if {$opt == "-value"} {
1358 set result [$widget(entry) get]
1360 set result $options($opt)
1365 set result [eval ::combobox::Configure {$w} $args]
1369 error "bad option \"$command\""
1376 # ::combobox::Configure --
1378 # Implements the "configure" widget subcommand
1383 # args zero or more option/value pairs (or a single option)
1387 # Performs typcial "configure" type requests on the widget
1389 proc ::combobox::Configure {w args} {
1390 variable widgetOptions
1391 variable defaultEntryCursor
1393 upvar ::combobox::${w}::widgets widgets
1394 upvar ::combobox::${w}::options options
1396 if {[llength $args] == 0} {
1397 # hmmm. User must be wanting all configuration information
1398 # note that if the value of an array element is of length
1399 # one it is an alias, which needs to be handled slightly
1402 foreach opt [lsort [array names widgetOptions]] {
1403 if {[llength $widgetOptions($opt)] == 1} {
1404 set alias $widgetOptions($opt)
1405 set optName $widgetOptions($alias)
1406 lappend results [list $opt $optName]
1408 set optName [lindex $widgetOptions($opt) 0]
1409 set optClass [lindex $widgetOptions($opt) 1]
1410 set default [option get $w $optName $optClass]
1411 lappend results [list $opt $optName $optClass \
1412 $default $options($opt)]
1419 # one argument means we are looking for configuration
1420 # information on a single option
1421 if {[llength $args] == 1} {
1422 set opt [::combobox::Canonize $w option [lindex $args 0]]
1424 set optName [lindex $widgetOptions($opt) 0]
1425 set optClass [lindex $widgetOptions($opt) 1]
1426 set default [option get $w $optName $optClass]
1427 set results [list $opt $optName $optClass \
1428 $default $options($opt)]
1432 # if we have an odd number of values, bail.
1433 if {[expr {[llength $args]%2}] == 1} {
1434 # hmmm. An odd number of elements in args
1435 error "value for \"[lindex $args end]\" missing"
1438 # Great. An even number of options. Let's make sure they
1439 # are all valid before we do anything. Note that Canonize
1440 # will generate an error if it finds a bogus option; otherwise
1441 # it returns the canonical option name
1442 foreach {name value} $args {
1443 set name [::combobox::Canonize $w option $name]
1444 set opts($name) $value
1447 # process all of the configuration options
1448 # some (actually, most) options require us to
1449 # do something, like change the attributes of
1450 # a widget or two. Here's where we do that...
1451 foreach option [array names opts] {
1452 set newValue $opts($option)
1453 if {[info exists options($option)]} {
1454 set oldValue $options($option)
1459 $widgets(frame) configure -background $newValue
1460 $widgets(entry) configure -background $newValue
1461 $widgets(listbox) configure -background $newValue
1462 $widgets(vsb) configure -background $newValue
1463 $widgets(vsb) configure -troughcolor $newValue
1464 set options($option) $newValue
1468 $widgets(frame) configure -borderwidth $newValue
1469 set options($option) $newValue
1473 # nothing else to do...
1474 set options($option) $newValue
1478 # do some value checking...
1479 if {$newValue != "normal" && $newValue != "disabled"} {
1480 set options($option) $oldValue
1481 set message "bad state value \"$newValue\";"
1482 append message " must be normal or disabled"
1485 set options($option) $newValue
1489 $widgets(frame) configure -cursor $newValue
1490 $widgets(entry) configure -cursor $newValue
1491 $widgets(listbox) configure -cursor $newValue
1492 set options($option) $newValue
1498 $widgets(entry) configure \
1500 -cursor $defaultEntryCursor
1502 $widgets(entry) configure \
1504 -cursor $options(-cursor)
1506 set options($option) $newValue
1510 $widgets(entry) configure -font $newValue
1511 $widgets(listbox) configure -font $newValue
1512 set options($option) $newValue
1516 $widgets(entry) configure -foreground $newValue
1517 $widgets(button) configure -foreground $newValue
1518 $widgets(listbox) configure -foreground $newValue
1519 set options($option) $newValue
1523 $widgets(listbox) configure -height $newValue
1525 set options($option) $newValue
1528 -highlightbackground {
1529 $widgets(frame) configure -highlightbackground $newValue
1530 set options($option) $newValue
1534 $widgets(frame) configure -highlightcolor $newValue
1535 set options($option) $newValue
1538 -highlightthickness {
1539 $widgets(frame) configure -highlightthickness $newValue
1540 set options($option) $newValue
1544 if {[string length $newValue] > 0} {
1545 $widgets(button) configure -image $newValue
1547 $widgets(button) configure -image ::combobox::bimage
1549 set options($option) $newValue
1553 # ComputeGeometry may dork with the actual height
1554 # of the listbox, so let's undork it
1555 $widgets(listbox) configure -height $options(-height)
1557 set options($option) $newValue
1561 $widgets(frame) configure -relief $newValue
1562 set options($option) $newValue
1566 $widgets(entry) configure -selectbackground $newValue
1567 $widgets(listbox) configure -selectbackground $newValue
1568 set options($option) $newValue
1571 -selectborderwidth {
1572 $widgets(entry) configure -selectborderwidth $newValue
1573 $widgets(listbox) configure -selectborderwidth $newValue
1574 set options($option) $newValue
1578 $widgets(entry) configure -selectforeground $newValue
1579 $widgets(listbox) configure -selectforeground $newValue
1580 set options($option) $newValue
1584 if {$newValue == "normal"} {
1586 set editable [::combobox::GetBoolean \
1587 $options(-editable)]
1589 $widgets(entry) configure -state normal
1590 $widgets(entry) configure -takefocus 1
1592 } elseif {$newValue == "disabled"} {
1594 $widgets(entry) configure -state disabled
1595 $widgets(entry) configure -takefocus 0
1598 set options($option) $oldValue
1599 set message "bad state value \"$newValue\";"
1600 append message " must be normal or disabled"
1604 set options($option) $newValue
1608 $widgets(entry) configure -takefocus $newValue
1609 set options($option) $newValue
1613 $widgets(entry) configure -textvariable $newValue
1614 set options($option) $newValue
1618 ::combobox::SetValue $widgets(this) $newValue
1619 set options($option) $newValue
1623 $widgets(entry) configure -width $newValue
1624 $widgets(listbox) configure -width $newValue
1625 set options($option) $newValue
1629 $widgets(entry) configure -xscrollcommand $newValue
1630 set options($option) $newValue
1637 # ::combobox::VTrace --
1639 # this proc is called whenever the user changes the value of
1640 # the -textvariable associated with a widget
1645 # args standard stuff from a variable trace
1651 proc ::combobox::VTrace {w args} {
1652 upvar ::combobox::${w}::widgets widgets
1653 upvar ::combobox::${w}::options options
1654 upvar ::combobox::${w}::ignoreTrace ignoreTrace
1656 if {[info exists ignoreTrace]} return
1657 ::combobox::SetValue $widgets(this) [set ::$options(-textvariable)]
1662 # ::combobox::SetValue --
1664 # sets the value of the combobox and calls the -command,
1670 # newValue the new value of the combobox
1676 proc ::combobox::SetValue {w newValue} {
1678 upvar ::combobox::${w}::widgets widgets
1679 upvar ::combobox::${w}::options options
1680 upvar ::combobox::${w}::ignoreTrace ignoreTrace
1681 upvar ::combobox::${w}::oldValue oldValue
1683 if {[info exists options(-textvariable)] \
1684 && [string length $options(-textvariable)] > 0} {
1685 set variable ::$options(-textvariable)
1686 set $variable $newValue
1688 set oldstate [$widgets(entry) cget -state]
1689 $widgets(entry) configure -state normal
1690 $widgets(entry) delete 0 end
1691 $widgets(entry) insert 0 $newValue
1692 $widgets(entry) configure -state $oldstate
1695 # set our internal textvariable; this will cause any public
1696 # textvariable (ie: defined by the user) to be updated as
1698 # set ::combobox::${w}::entryTextVariable $newValue
1700 # redefine our concept of the "old value". Do it before running
1701 # any associated command so we can be sure it happens even
1702 # if the command somehow fails.
1703 set oldValue $newValue
1706 # call the associated command. The proc will handle whether or
1707 # not to actually call it, and with what args
1708 CallCommand $w $newValue
1713 # ::combobox::CallCommand --
1715 # calls the associated command, if any, appending the new
1716 # value to the command to be called.
1721 # newValue the new value of the combobox
1727 proc ::combobox::CallCommand {w newValue} {
1728 upvar ::combobox::${w}::widgets widgets
1729 upvar ::combobox::${w}::options options
1731 # call the associated command, if defined and -commandstate is
1733 if {$options(-commandstate) == "normal" && \
1734 [string length $options(-command)] > 0} {
1735 set args [list $widgets(this) $newValue]
1736 uplevel \#0 $options(-command) $args
1741 # ::combobox::GetBoolean --
1743 # returns the value of a (presumably) boolean string (ie: it should
1744 # do the right thing if the string is "yes", "no", "true", 1, etc
1748 # value value to be converted
1749 # errorValue a default value to be returned in case of an error
1753 # a 1 or zero, or the value of errorValue if the string isn't
1754 # a proper boolean value
1756 proc ::combobox::GetBoolean {value {errorValue 1}} {
1757 if {[catch {expr {([string trim $value])?1:0}} res]} {
1764 # ::combobox::convert --
1766 # public routine to convert %x, %y and %W binding substitutions.
1767 # Given an x, y and or %W value relative to a given widget, this
1768 # routine will convert the values to be relative to the combobox
1769 # widget. For example, it could be used in a binding like this:
1771 # bind .combobox <blah> {doSomething [::combobox::convert %W -x %x]}
1773 # Note that this procedure is *not* exported, but is indented for
1774 # public use. It is not exported because the name could easily
1775 # clash with existing commands.
1779 # w a widget path; typically the actual result of a %W
1780 # substitution in a binding. It should be either a
1781 # combobox widget or one of its subwidgets
1783 # args should one or more of the following arguments or
1784 # pairs of arguments:
1786 # -x <x> will convert the value <x>; typically <x> will
1787 # be the result of a %x substitution
1788 # -y <y> will convert the value <y>; typically <y> will
1789 # be the result of a %y substitution
1790 # -W (or -w) will return the name of the combobox widget
1791 # which is the parent of $w
1795 # a list of the requested values. For example, a single -w will
1796 # result in a list of one items, the name of the combobox widget.
1797 # Supplying "-x 10 -y 20 -W" (in any order) will return a list of
1798 # three values: the converted x and y values, and the name of
1799 # the combobox widget.
1801 proc ::combobox::convert {w args} {
1803 if {![winfo exists $w]} {
1804 error "window \"$w\" doesn't exist"
1807 while {[llength $args] > 0} {
1808 set option [lindex $args 0]
1809 set args [lrange $args 1 end]
1811 switch -exact -- $option {
1813 set value [lindex $args 0]
1814 set args [lrange $args 1 end]
1816 while {[winfo class $win] != "Combobox"} {
1817 incr value [winfo x $win]
1818 set win [winfo parent $win]
1819 if {$win == "."} break
1821 lappend result $value
1825 set value [lindex $args 0]
1826 set args [lrange $args 1 end]
1828 while {[winfo class $win] != "Combobox"} {
1829 incr value [winfo y $win]
1830 set win [winfo parent $win]
1831 if {$win == "."} break
1833 lappend result $value
1839 while {[winfo class $win] != "Combobox"} {
1840 set win [winfo parent $win]
1841 if {$win == "."} break;
1850 # ::combobox::Canonize --
1852 # takes a (possibly abbreviated) option or command name and either
1853 # returns the canonical name or an error
1858 # object type of object to canonize; must be one of "command",
1859 # "option", "scan command" or "list command"
1860 # opt the option (or command) to be canonized
1864 # Returns either the canonical form of an option or command,
1865 # or raises an error if the option or command is unknown or
1868 proc ::combobox::Canonize {w object opt} {
1869 variable widgetOptions
1870 variable columnOptions
1871 variable widgetCommands
1872 variable listCommands
1873 variable scanCommands
1877 if {[lsearch -exact $widgetCommands $opt] >= 0} {
1881 # command names aren't stored in an array, and there
1882 # isn't a way to get all the matches in a list, so
1883 # we'll stuff the commands in a temporary array so
1884 # we can use [array names]
1885 set list $widgetCommands
1886 foreach element $list {
1887 set tmp($element) ""
1889 set matches [array names tmp ${opt}*]
1893 if {[lsearch -exact $listCommands $opt] >= 0} {
1897 # command names aren't stored in an array, and there
1898 # isn't a way to get all the matches in a list, so
1899 # we'll stuff the commands in a temporary array so
1900 # we can use [array names]
1901 set list $listCommands
1902 foreach element $list {
1903 set tmp($element) ""
1905 set matches [array names tmp ${opt}*]
1909 if {[lsearch -exact $scanCommands $opt] >= 0} {
1913 # command names aren't stored in an array, and there
1914 # isn't a way to get all the matches in a list, so
1915 # we'll stuff the commands in a temporary array so
1916 # we can use [array names]
1917 set list $scanCommands
1918 foreach element $list {
1919 set tmp($element) ""
1921 set matches [array names tmp ${opt}*]
1925 if {[info exists widgetOptions($opt)] \
1926 && [llength $widgetOptions($opt)] == 2} {
1929 set list [array names widgetOptions]
1930 set matches [array names widgetOptions ${opt}*]
1935 if {[llength $matches] == 0} {
1936 set choices [HumanizeList $list]
1937 error "unknown $object \"$opt\"; must be one of $choices"
1939 } elseif {[llength $matches] == 1} {
1940 set opt [lindex $matches 0]
1942 # deal with option aliases
1945 set opt [lindex $matches 0]
1946 if {[llength $widgetOptions($opt)] == 1} {
1947 set opt $widgetOptions($opt)
1955 set choices [HumanizeList $list]
1956 error "ambiguous $object \"$opt\"; must be one of $choices"
1960 # ::combobox::HumanizeList --
1962 # Returns a human-readable form of a list by separating items
1963 # by columns, but separating the last two elements with "or"
1964 # (eg: foo, bar or baz)
1968 # list a valid tcl list
1972 # A string which as all of the elements joined with ", " or
1975 proc ::combobox::HumanizeList {list} {
1977 if {[llength $list] == 1} {
1978 return [lindex $list 0]
1980 set list [lsort $list]
1981 set secondToLast [expr {[llength $list] -2}]
1982 set most [lrange $list 0 $secondToLast]
1983 set last [lindex $list end]
1985 return "[join $most {, }] or $last"
1989 # end of combobox.tcl