| # Copyright (c) 1998-2003, Bryan Oakley |
| # All Rights Reservered |
| # |
| # Bryan Oakley |
| # oakley@bardo.clearlight.com |
| # |
| # combobox v2.3 August 16, 2003 |
| # |
| # a combobox / dropdown listbox (pick your favorite name) widget |
| # written in pure tcl |
| # |
| # this code is freely distributable without restriction, but is |
| # provided as-is with no warranty expressed or implied. |
| # |
| # thanks to the following people who provided beta test support or |
| # patches to the code (in no particular order): |
| # |
| # Scott Beasley Alexandre Ferrieux Todd Helfter |
| # Matt Gushee Laurent Duperval John Jackson |
| # Fred Rapp Christopher Nelson |
| # Eric Galluzzo Jean-Francois Moine Oliver Bienert |
| # |
| # A special thanks to Martin M. Hunt who provided several good ideas, |
| # and always with a patch to implement them. Jean-Francois Moine, |
| # Todd Helfter and John Jackson were also kind enough to send in some |
| # code patches. |
| # |
| # ... and many others over the years. |
| |
| package require Tk 8.0 |
| package provide combobox 2.3 |
| |
| namespace eval ::combobox { |
| |
| # this is the public interface |
| namespace export combobox |
| |
| # these contain references to available options |
| variable widgetOptions |
| |
| # these contain references to available commands and subcommands |
| variable widgetCommands |
| variable scanCommands |
| variable listCommands |
| } |
| |
| # ::combobox::combobox -- |
| # |
| # This is the command that gets exported. It creates a new |
| # combobox widget. |
| # |
| # Arguments: |
| # |
| # w path of new widget to create |
| # args additional option/value pairs (eg: -background white, etc.) |
| # |
| # Results: |
| # |
| # It creates the widget and sets up all of the default bindings |
| # |
| # Returns: |
| # |
| # The name of the newly create widget |
| |
| proc ::combobox::combobox {w args} { |
| variable widgetOptions |
| variable widgetCommands |
| variable scanCommands |
| variable listCommands |
| |
| # perform a one time initialization |
| if {![info exists widgetOptions]} { |
| Init |
| } |
| |
| # build it... |
| eval Build $w $args |
| |
| # set some bindings... |
| SetBindings $w |
| |
| # and we are done! |
| return $w |
| } |
| |
| |
| # ::combobox::Init -- |
| # |
| # Initialize the namespace variables. This should only be called |
| # once, immediately prior to creating the first instance of the |
| # widget |
| # |
| # Arguments: |
| # |
| # none |
| # |
| # Results: |
| # |
| # All state variables are set to their default values; all of |
| # the option database entries will exist. |
| # |
| # Returns: |
| # |
| # empty string |
| |
| proc ::combobox::Init {} { |
| variable widgetOptions |
| variable widgetCommands |
| variable scanCommands |
| variable listCommands |
| variable defaultEntryCursor |
| |
| array set widgetOptions [list \ |
| -background {background Background} \ |
| -bd -borderwidth \ |
| -bg -background \ |
| -borderwidth {borderWidth BorderWidth} \ |
| -buttonbackground {buttonBackground Background} \ |
| -command {command Command} \ |
| -commandstate {commandState State} \ |
| -cursor {cursor Cursor} \ |
| -disabledbackground {disabledBackground DisabledBackground} \ |
| -disabledforeground {disabledForeground DisabledForeground} \ |
| -dropdownwidth {dropdownWidth DropdownWidth} \ |
| -editable {editable Editable} \ |
| -elementborderwidth {elementBorderWidth BorderWidth} \ |
| -fg -foreground \ |
| -font {font Font} \ |
| -foreground {foreground Foreground} \ |
| -height {height Height} \ |
| -highlightbackground {highlightBackground HighlightBackground} \ |
| -highlightcolor {highlightColor HighlightColor} \ |
| -highlightthickness {highlightThickness HighlightThickness} \ |
| -image {image Image} \ |
| -listvar {listVariable Variable} \ |
| -maxheight {maxHeight Height} \ |
| -opencommand {opencommand Command} \ |
| -relief {relief Relief} \ |
| -selectbackground {selectBackground Foreground} \ |
| -selectborderwidth {selectBorderWidth BorderWidth} \ |
| -selectforeground {selectForeground Background} \ |
| -state {state State} \ |
| -takefocus {takeFocus TakeFocus} \ |
| -textvariable {textVariable Variable} \ |
| -value {value Value} \ |
| -width {width Width} \ |
| -xscrollcommand {xScrollCommand ScrollCommand} \ |
| ] |
| |
| |
| set widgetCommands [list \ |
| bbox cget configure curselection \ |
| delete get icursor index \ |
| insert list scan selection \ |
| xview select toggle open \ |
| close entryset subwidget \ |
| ] |
| |
| set listCommands [list \ |
| delete get \ |
| index insert size \ |
| ] |
| |
| set scanCommands [list mark dragto] |
| |
| # why check for the Tk package? This lets us be sourced into |
| # an interpreter that doesn't have Tk loaded, such as the slave |
| # interpreter used by pkg_mkIndex. In theory it should have no |
| # side effects when run |
| if {[lsearch -exact [package names] "Tk"] != -1} { |
| |
| ################################################################## |
| #- this initializes the option database. Kinda gross, but it works |
| #- (I think). |
| ################################################################## |
| |
| # the image used for the button... |
| if {$::tcl_platform(platform) == "windows"} { |
| image create bitmap ::combobox::bimage -data { |
| #define down_arrow_width 12 |
| #define down_arrow_height 12 |
| static char down_arrow_bits[] = { |
| 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, |
| 0xfc,0xf1,0xf8,0xf0,0x70,0xf0,0x20,0xf0, |
| 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00; |
| } |
| } |
| } else { |
| image create bitmap ::combobox::bimage -data { |
| #define down_arrow_width 15 |
| #define down_arrow_height 15 |
| static char down_arrow_bits[] = { |
| 0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80, |
| 0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83, |
| 0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80, |
| 0x00,0x80,0x00,0x80,0x00,0x80 |
| } |
| } |
| } |
| |
| # compute a widget name we can use to create a temporary widget |
| set tmpWidget ".__tmp__" |
| set count 0 |
| while {[winfo exists $tmpWidget] == 1} { |
| set tmpWidget ".__tmp__$count" |
| incr count |
| } |
| |
| # get the scrollbar width. Because we try to be clever and draw our |
| # own button instead of using a tk widget, we need to know what size |
| # button to create. This little hack tells us the width of a scroll |
| # bar. |
| # |
| # NB: we need to be sure and pick a window that doesn't already |
| # exist... |
| scrollbar $tmpWidget |
| set sb_width [winfo reqwidth $tmpWidget] |
| set bbg [$tmpWidget cget -background] |
| destroy $tmpWidget |
| |
| # steal options from the entry widget |
| # we want darn near all options, so we'll go ahead and do |
| # them all. No harm done in adding the one or two that we |
| # don't use. |
| entry $tmpWidget |
| foreach foo [$tmpWidget configure] { |
| # the cursor option is special, so we'll save it in |
| # a special way |
| if {[lindex $foo 0] == "-cursor"} { |
| set defaultEntryCursor [lindex $foo 4] |
| } |
| if {[llength $foo] == 5} { |
| set option [lindex $foo 1] |
| set value [lindex $foo 4] |
| option add *Combobox.$option $value widgetDefault |
| |
| # these options also apply to the dropdown listbox |
| if {[string compare $option "foreground"] == 0 \ |
| || [string compare $option "background"] == 0 \ |
| || [string compare $option "font"] == 0} { |
| option add *Combobox*ComboboxListbox.$option $value \ |
| widgetDefault |
| } |
| } |
| } |
| destroy $tmpWidget |
| |
| # these are unique to us... |
| option add *Combobox.elementBorderWidth 1 widgetDefault |
| option add *Combobox.buttonBackground $bbg widgetDefault |
| option add *Combobox.dropdownWidth {} widgetDefault |
| option add *Combobox.openCommand {} widgetDefault |
| option add *Combobox.cursor {} widgetDefault |
| option add *Combobox.commandState normal widgetDefault |
| option add *Combobox.editable 1 widgetDefault |
| option add *Combobox.maxHeight 10 widgetDefault |
| option add *Combobox.height 0 |
| } |
| |
| # set class bindings |
| SetClassBindings |
| } |
| |
| # ::combobox::SetClassBindings -- |
| # |
| # Sets up the default bindings for the widget class |
| # |
| # this proc exists since it's The Right Thing To Do, but |
| # I haven't had the time to figure out how to do all the |
| # binding stuff on a class level. The main problem is that |
| # the entry widget must have focus for the insertion cursor |
| # to be visible. So, I either have to have the entry widget |
| # have the Combobox bindtag, or do some fancy juggling of |
| # events or some such. What a pain. |
| # |
| # Arguments: |
| # |
| # none |
| # |
| # Returns: |
| # |
| # empty string |
| |
| proc ::combobox::SetClassBindings {} { |
| |
| # make sure we clean up after ourselves... |
| bind Combobox <Destroy> [list ::combobox::DestroyHandler %W] |
| |
| # this will (hopefully) close (and lose the grab on) the |
| # listbox if the user clicks anywhere outside of it. Note |
| # that on Windows, you can click on some other app and |
| # the listbox will still be there, because tcl won't see |
| # that button click |
| set this {[::combobox::convert %W -W]} |
| bind Combobox <Any-ButtonPress> "$this close" |
| bind Combobox <Any-ButtonRelease> "$this close" |
| |
| # this helps (but doesn't fully solve) focus issues. The general |
| # idea is, whenever the frame gets focus it gets passed on to |
| # the entry widget |
| bind Combobox <FocusIn> {::combobox::tkTabToWindow \ |
| [::combobox::convert %W -W].entry} |
| |
| # this closes the listbox if we get hidden |
| bind Combobox <Unmap> {[::combobox::convert %W -W] close} |
| |
| return "" |
| } |
| |
| # ::combobox::SetBindings -- |
| # |
| # here's where we do most of the binding foo. I think there's probably |
| # a few bindings I ought to add that I just haven't thought |
| # about... |
| # |
| # I'm not convinced these are the proper bindings. Ideally all |
| # bindings should be on "Combobox", but because of my juggling of |
| # bindtags I'm not convinced thats what I want to do. But, it all |
| # seems to work, its just not as robust as it could be. |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # |
| # Returns: |
| # |
| # empty string |
| |
| proc ::combobox::SetBindings {w} { |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| |
| # juggle the bindtags. The basic idea here is to associate the |
| # widget name with the entry widget, so if a user does a bind |
| # on the combobox it will get handled properly since it is |
| # the entry widget that has keyboard focus. |
| bindtags $widgets(entry) \ |
| [concat $widgets(this) [bindtags $widgets(entry)]] |
| |
| bindtags $widgets(button) \ |
| [concat $widgets(this) [bindtags $widgets(button)]] |
| |
| # override the default bindings for tab and shift-tab. The |
| # focus procs take a widget as their only parameter and we |
| # want to make sure the right window gets used (for shift- |
| # tab we want it to appear as if the event was generated |
| # on the frame rather than the entry. |
| bind $widgets(entry) <Tab> \ |
| "::combobox::tkTabToWindow \[tk_focusNext $widgets(entry)\]; break" |
| bind $widgets(entry) <Shift-Tab> \ |
| "::combobox::tkTabToWindow \[tk_focusPrev $widgets(this)\]; break" |
| |
| # this makes our "button" (which is actually a label) |
| # do the right thing |
| bind $widgets(button) <ButtonPress-1> [list $widgets(this) toggle] |
| |
| # this lets the autoscan of the listbox work, even if they |
| # move the cursor over the entry widget. |
| bind $widgets(entry) <B1-Enter> "break" |
| |
| bind $widgets(listbox) <ButtonRelease-1> \ |
| "::combobox::Select [list $widgets(this)] \ |
| \[$widgets(listbox) nearest %y\]; break" |
| |
| bind $widgets(vsb) <ButtonPress-1> {continue} |
| bind $widgets(vsb) <ButtonRelease-1> {continue} |
| |
| bind $widgets(listbox) <Any-Motion> { |
| %W selection clear 0 end |
| %W activate @%x,%y |
| %W selection anchor @%x,%y |
| %W selection set @%x,%y @%x,%y |
| # need to do a yview if the cursor goes off the top |
| # or bottom of the window... (or do we?) |
| } |
| |
| # these events need to be passed from the entry widget |
| # to the listbox, or otherwise need some sort of special |
| # handling. |
| foreach event [list <Up> <Down> <Tab> <Return> <Escape> \ |
| <Next> <Prior> <Double-1> <1> <Any-KeyPress> \ |
| <FocusIn> <FocusOut>] { |
| bind $widgets(entry) $event \ |
| [list ::combobox::HandleEvent $widgets(this) $event] |
| } |
| |
| # like the other events, <MouseWheel> needs to be passed from |
| # the entry widget to the listbox. However, in this case we |
| # need to add an additional parameter |
| catch { |
| bind $widgets(entry) <MouseWheel> \ |
| [list ::combobox::HandleEvent $widgets(this) <MouseWheel> %D] |
| } |
| } |
| |
| # ::combobox::Build -- |
| # |
| # This does all of the work necessary to create the basic |
| # combobox. |
| # |
| # Arguments: |
| # |
| # w widget name |
| # args additional option/value pairs |
| # |
| # Results: |
| # |
| # Creates a new widget with the given name. Also creates a new |
| # namespace patterened after the widget name, as a child namespace |
| # to ::combobox |
| # |
| # Returns: |
| # |
| # the name of the widget |
| |
| proc ::combobox::Build {w args } { |
| variable widgetOptions |
| |
| if {[winfo exists $w]} { |
| error "window name \"$w\" already exists" |
| } |
| |
| # create the namespace for this instance, and define a few |
| # variables |
| namespace eval ::combobox::$w { |
| |
| variable ignoreTrace 0 |
| variable oldFocus {} |
| variable oldGrab {} |
| variable oldValue {} |
| variable options |
| variable this |
| variable widgets |
| |
| set widgets(foo) foo ;# coerce into an array |
| set options(foo) foo ;# coerce into an array |
| |
| unset widgets(foo) |
| unset options(foo) |
| } |
| |
| # import the widgets and options arrays into this proc so |
| # we don't have to use fully qualified names, which is a |
| # pain. |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| |
| # this is our widget -- a frame of class Combobox. Naturally, |
| # it will contain other widgets. We create it here because |
| # we need it in order to set some default options. |
| set widgets(this) [frame $w -class Combobox -takefocus 0] |
| set widgets(entry) [entry $w.entry -takefocus 1] |
| set widgets(button) [label $w.button -takefocus 0] |
| |
| # this defines all of the default options. We get the |
| # values from the option database. Note that if an array |
| # value is a list of length one it is an alias to another |
| # option, so we just ignore it |
| foreach name [array names widgetOptions] { |
| if {[llength $widgetOptions($name)] == 1} continue |
| |
| set optName [lindex $widgetOptions($name) 0] |
| set optClass [lindex $widgetOptions($name) 1] |
| |
| set value [option get $w $optName $optClass] |
| set options($name) $value |
| } |
| |
| # a couple options aren't available in earlier versions of |
| # tcl, so we'll set them to sane values. For that matter, if |
| # they exist but are empty, set them to sane values. |
| if {[string length $options(-disabledforeground)] == 0} { |
| set options(-disabledforeground) $options(-foreground) |
| } |
| if {[string length $options(-disabledbackground)] == 0} { |
| set options(-disabledbackground) $options(-background) |
| } |
| |
| # if -value is set to null, we'll remove it from our |
| # local array. The assumption is, if the user sets it from |
| # the option database, they will set it to something other |
| # than null (since it's impossible to determine the difference |
| # between a null value and no value at all). |
| if {[info exists options(-value)] \ |
| && [string length $options(-value)] == 0} { |
| unset options(-value) |
| } |
| |
| # we will later rename the frame's widget proc to be our |
| # own custom widget proc. We need to keep track of this |
| # new name, so we'll define and store it here... |
| set widgets(frame) ::combobox::${w}::$w |
| |
| # gotta do this sooner or later. Might as well do it now |
| pack $widgets(button) -side right -fill y -expand no |
| pack $widgets(entry) -side left -fill both -expand yes |
| |
| # I should probably do this in a catch, but for now it's |
| # good enough... What it does, obviously, is put all of |
| # the option/values pairs into an array. Make them easier |
| # to handle later on... |
| array set options $args |
| |
| # now, the dropdown list... the same renaming nonsense |
| # must go on here as well... |
| set widgets(dropdown) [toplevel $w.top] |
| set widgets(listbox) [listbox $w.top.list] |
| set widgets(vsb) [scrollbar $w.top.vsb] |
| |
| pack $widgets(listbox) -side left -fill both -expand y |
| |
| # fine tune the widgets based on the options (and a few |
| # arbitrary values...) |
| |
| # NB: we are going to use the frame to handle the relief |
| # of the widget as a whole, so the entry widget will be |
| # flat. This makes the button which drops down the list |
| # to appear "inside" the entry widget. |
| |
| $widgets(vsb) configure \ |
| -borderwidth 1 \ |
| -command "$widgets(listbox) yview" \ |
| -highlightthickness 0 |
| |
| $widgets(button) configure \ |
| -background $options(-buttonbackground) \ |
| -highlightthickness 0 \ |
| -borderwidth $options(-elementborderwidth) \ |
| -relief raised \ |
| -width [expr {[winfo reqwidth $widgets(vsb)] - 2}] |
| |
| $widgets(entry) configure \ |
| -borderwidth 0 \ |
| -relief flat \ |
| -highlightthickness 0 |
| |
| $widgets(dropdown) configure \ |
| -borderwidth $options(-elementborderwidth) \ |
| -relief sunken |
| |
| $widgets(listbox) configure \ |
| -selectmode browse \ |
| -background [$widgets(entry) cget -bg] \ |
| -yscrollcommand "$widgets(vsb) set" \ |
| -exportselection false \ |
| -borderwidth 0 |
| |
| |
| # trace variable ::combobox::${w}::entryTextVariable w \ |
| # [list ::combobox::EntryTrace $w] |
| |
| # do some window management foo on the dropdown window |
| wm overrideredirect $widgets(dropdown) 1 |
| wm transient $widgets(dropdown) [winfo toplevel $w] |
| wm group $widgets(dropdown) [winfo parent $w] |
| wm resizable $widgets(dropdown) 0 0 |
| wm withdraw $widgets(dropdown) |
| |
| # this moves the original frame widget proc into our |
| # namespace and gives it a handy name |
| rename ::$w $widgets(frame) |
| |
| # now, create our widget proc. Obviously (?) it goes in |
| # the global namespace. All combobox widgets will actually |
| # share the same widget proc to cut down on the amount of |
| # bloat. |
| proc ::$w {command args} \ |
| "eval ::combobox::WidgetProc $w \$command \$args" |
| |
| |
| # ok, the thing exists... let's do a bit more configuration. |
| if {[catch "::combobox::Configure [list $widgets(this)] [array get options]" error]} { |
| catch {destroy $w} |
| error "internal error: $error" |
| } |
| |
| return "" |
| |
| } |
| |
| # ::combobox::HandleEvent -- |
| # |
| # this proc handles events from the entry widget that we want |
| # handled specially (typically, to allow navigation of the list |
| # even though the focus is in the entry widget) |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # event a string representing the event (not necessarily an |
| # actual event) |
| # args additional arguments required by particular events |
| |
| proc ::combobox::HandleEvent {w event args} { |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| upvar ::combobox::${w}::oldValue oldValue |
| |
| # for all of these events, if we have a special action we'll |
| # do that and do a "return -code break" to keep additional |
| # bindings from firing. Otherwise we'll let the event fall |
| # on through. |
| switch $event { |
| |
| "<MouseWheel>" { |
| if {[winfo ismapped $widgets(dropdown)]} { |
| set D [lindex $args 0] |
| # the '120' number in the following expression has |
| # it's genesis in the tk bind manpage, which suggests |
| # that the smallest value of %D for mousewheel events |
| # will be 120. The intent is to scroll one line at a time. |
| $widgets(listbox) yview scroll [expr {-($D/120)}] units |
| } |
| } |
| |
| "<Any-KeyPress>" { |
| # if the widget is editable, clear the selection. |
| # this makes it more obvious what will happen if the |
| # user presses <Return> (and helps our code know what |
| # to do if the user presses return) |
| if {$options(-editable)} { |
| $widgets(listbox) see 0 |
| $widgets(listbox) selection clear 0 end |
| $widgets(listbox) selection anchor 0 |
| $widgets(listbox) activate 0 |
| } |
| } |
| |
| "<FocusIn>" { |
| set oldValue [$widgets(entry) get] |
| } |
| |
| "<FocusOut>" { |
| if {![winfo ismapped $widgets(dropdown)]} { |
| # did the value change? |
| set newValue [$widgets(entry) get] |
| if {$oldValue != $newValue} { |
| CallCommand $widgets(this) $newValue |
| } |
| } |
| } |
| |
| "<1>" { |
| set editable [::combobox::GetBoolean $options(-editable)] |
| if {!$editable} { |
| if {[winfo ismapped $widgets(dropdown)]} { |
| $widgets(this) close |
| return -code break; |
| |
| } else { |
| if {$options(-state) != "disabled"} { |
| $widgets(this) open |
| return -code break; |
| } |
| } |
| } |
| } |
| |
| "<Double-1>" { |
| if {$options(-state) != "disabled"} { |
| $widgets(this) toggle |
| return -code break; |
| } |
| } |
| |
| "<Tab>" { |
| if {[winfo ismapped $widgets(dropdown)]} { |
| ::combobox::Find $widgets(this) 0 |
| return -code break; |
| } else { |
| ::combobox::SetValue $widgets(this) [$widgets(this) get] |
| } |
| } |
| |
| "<Escape>" { |
| # $widgets(entry) delete 0 end |
| # $widgets(entry) insert 0 $oldValue |
| if {[winfo ismapped $widgets(dropdown)]} { |
| $widgets(this) close |
| return -code break; |
| } |
| } |
| |
| "<Return>" { |
| # did the value change? |
| set newValue [$widgets(entry) get] |
| if {$oldValue != $newValue} { |
| CallCommand $widgets(this) $newValue |
| } |
| |
| if {[winfo ismapped $widgets(dropdown)]} { |
| ::combobox::Select $widgets(this) \ |
| [$widgets(listbox) curselection] |
| return -code break; |
| } |
| |
| } |
| |
| "<Next>" { |
| $widgets(listbox) yview scroll 1 pages |
| set index [$widgets(listbox) index @0,0] |
| $widgets(listbox) see $index |
| $widgets(listbox) activate $index |
| $widgets(listbox) selection clear 0 end |
| $widgets(listbox) selection anchor $index |
| $widgets(listbox) selection set $index |
| |
| } |
| |
| "<Prior>" { |
| $widgets(listbox) yview scroll -1 pages |
| set index [$widgets(listbox) index @0,0] |
| $widgets(listbox) activate $index |
| $widgets(listbox) see $index |
| $widgets(listbox) selection clear 0 end |
| $widgets(listbox) selection anchor $index |
| $widgets(listbox) selection set $index |
| } |
| |
| "<Down>" { |
| if {[winfo ismapped $widgets(dropdown)]} { |
| ::combobox::tkListboxUpDown $widgets(listbox) 1 |
| return -code break; |
| |
| } else { |
| if {$options(-state) != "disabled"} { |
| $widgets(this) open |
| return -code break; |
| } |
| } |
| } |
| "<Up>" { |
| if {[winfo ismapped $widgets(dropdown)]} { |
| ::combobox::tkListboxUpDown $widgets(listbox) -1 |
| return -code break; |
| |
| } else { |
| if {$options(-state) != "disabled"} { |
| $widgets(this) open |
| return -code break; |
| } |
| } |
| } |
| } |
| |
| return "" |
| } |
| |
| # ::combobox::DestroyHandler {w} -- |
| # |
| # Cleans up after a combobox widget is destroyed |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # |
| # Results: |
| # |
| # The namespace that was created for the widget is deleted, |
| # and the widget proc is removed. |
| |
| proc ::combobox::DestroyHandler {w} { |
| |
| catch { |
| # if the widget actually being destroyed is of class Combobox, |
| # remove the namespace and associated proc. |
| if {[string compare [winfo class $w] "Combobox"] == 0} { |
| # delete the namespace and the proc which represents |
| # our widget |
| namespace delete ::combobox::$w |
| rename $w {} |
| } |
| } |
| return "" |
| } |
| |
| # ::combobox::Find |
| # |
| # finds something in the listbox that matches the pattern in the |
| # entry widget and selects it |
| # |
| # N.B. I'm not convinced this is working the way it ought to. It |
| # works, but is the behavior what is expected? I've also got a gut |
| # feeling that there's a better way to do this, but I'm too lazy to |
| # figure it out... |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # exact boolean; if true an exact match is desired |
| # |
| # Returns: |
| # |
| # Empty string |
| |
| proc ::combobox::Find {w {exact 0}} { |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| |
| ## *sigh* this logic is rather gross and convoluted. Surely |
| ## there is a more simple, straight-forward way to implement |
| ## all this. As the saying goes, I lack the time to make it |
| ## shorter... |
| |
| # use what is already in the entry widget as a pattern |
| set pattern [$widgets(entry) get] |
| |
| if {[string length $pattern] == 0} { |
| # clear the current selection |
| $widgets(listbox) see 0 |
| $widgets(listbox) selection clear 0 end |
| $widgets(listbox) selection anchor 0 |
| $widgets(listbox) activate 0 |
| return |
| } |
| |
| # we're going to be searching this list... |
| set list [$widgets(listbox) get 0 end] |
| |
| # if we are doing an exact match, try to find, |
| # well, an exact match |
| set exactMatch -1 |
| if {$exact} { |
| set exactMatch [lsearch -exact $list $pattern] |
| } |
| |
| # search for it. We'll try to be clever and not only |
| # search for a match for what they typed, but a match for |
| # something close to what they typed. We'll keep removing one |
| # character at a time from the pattern until we find a match |
| # of some sort. |
| set index -1 |
| while {$index == -1 && [string length $pattern]} { |
| set index [lsearch -glob $list "$pattern*"] |
| if {$index == -1} { |
| regsub {.$} $pattern {} pattern |
| } |
| } |
| |
| # this is the item that most closely matches... |
| set thisItem [lindex $list $index] |
| |
| # did we find a match? If so, do some additional munging... |
| if {$index != -1} { |
| |
| # we need to find the part of the first item that is |
| # unique WRT the second... I know there's probably a |
| # simpler way to do this... |
| |
| set nextIndex [expr {$index + 1}] |
| set nextItem [lindex $list $nextIndex] |
| |
| # we don't really need to do much if the next |
| # item doesn't match our pattern... |
| if {[string match $pattern* $nextItem]} { |
| # ok, the next item matches our pattern, too |
| # now the trick is to find the first character |
| # where they *don't* match... |
| set marker [string length $pattern] |
| while {$marker <= [string length $pattern]} { |
| set a [string index $thisItem $marker] |
| set b [string index $nextItem $marker] |
| if {[string compare $a $b] == 0} { |
| append pattern $a |
| incr marker |
| } else { |
| break |
| } |
| } |
| } else { |
| set marker [string length $pattern] |
| } |
| |
| } else { |
| set marker end |
| set index 0 |
| } |
| |
| # ok, we know the pattern and what part is unique; |
| # update the entry widget and listbox appropriately |
| if {$exact && $exactMatch == -1} { |
| # this means we didn't find an exact match |
| $widgets(listbox) selection clear 0 end |
| $widgets(listbox) see $index |
| |
| } elseif {!$exact} { |
| # this means we found something, but it isn't an exact |
| # match. If we find something that *is* an exact match we |
| # don't need to do the following, since it would merely |
| # be replacing the data in the entry widget with itself |
| set oldstate [$widgets(entry) cget -state] |
| $widgets(entry) configure -state normal |
| $widgets(entry) delete 0 end |
| $widgets(entry) insert end $thisItem |
| $widgets(entry) selection clear |
| $widgets(entry) selection range $marker end |
| $widgets(listbox) activate $index |
| $widgets(listbox) selection clear 0 end |
| $widgets(listbox) selection anchor $index |
| $widgets(listbox) selection set $index |
| $widgets(listbox) see $index |
| $widgets(entry) configure -state $oldstate |
| } |
| } |
| |
| # ::combobox::Select -- |
| # |
| # selects an item from the list and sets the value of the combobox |
| # to that value |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # index listbox index of item to be selected |
| # |
| # Returns: |
| # |
| # empty string |
| |
| proc ::combobox::Select {w index} { |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| |
| # the catch is because I'm sloppy -- presumably, the only time |
| # an error will be caught is if there is no selection. |
| if {![catch {set data [$widgets(listbox) get [lindex $index 0]]}]} { |
| ::combobox::SetValue $widgets(this) $data |
| |
| $widgets(listbox) selection clear 0 end |
| $widgets(listbox) selection anchor $index |
| $widgets(listbox) selection set $index |
| |
| } |
| $widgets(entry) selection range 0 end |
| $widgets(entry) icursor end |
| |
| $widgets(this) close |
| |
| return "" |
| } |
| |
| # ::combobox::HandleScrollbar -- |
| # |
| # causes the scrollbar of the dropdown list to appear or disappear |
| # based on the contents of the dropdown listbox |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # action the action to perform on the scrollbar |
| # |
| # Returns: |
| # |
| # an empty string |
| |
| proc ::combobox::HandleScrollbar {w {action "unknown"}} { |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| |
| if {$options(-height) == 0} { |
| set hlimit $options(-maxheight) |
| } else { |
| set hlimit $options(-height) |
| } |
| |
| switch $action { |
| "grow" { |
| if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} { |
| pack forget $widgets(listbox) |
| pack $widgets(vsb) -side right -fill y -expand n |
| pack $widgets(listbox) -side left -fill both -expand y |
| } |
| } |
| |
| "shrink" { |
| if {$hlimit > 0 && [$widgets(listbox) size] <= $hlimit} { |
| pack forget $widgets(vsb) |
| } |
| } |
| |
| "crop" { |
| # this means the window was cropped and we definitely |
| # need a scrollbar no matter what the user wants |
| pack forget $widgets(listbox) |
| pack $widgets(vsb) -side right -fill y -expand n |
| pack $widgets(listbox) -side left -fill both -expand y |
| } |
| |
| default { |
| if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} { |
| pack forget $widgets(listbox) |
| pack $widgets(vsb) -side right -fill y -expand n |
| pack $widgets(listbox) -side left -fill both -expand y |
| } else { |
| pack forget $widgets(vsb) |
| } |
| } |
| } |
| |
| return "" |
| } |
| |
| # ::combobox::ComputeGeometry -- |
| # |
| # computes the geometry of the dropdown list based on the size of the |
| # combobox... |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # |
| # Returns: |
| # |
| # the desired geometry of the listbox |
| |
| proc ::combobox::ComputeGeometry {w} { |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| |
| if {$options(-height) == 0 && $options(-maxheight) != "0"} { |
| # if this is the case, count the items and see if |
| # it exceeds our maxheight. If so, set the listbox |
| # size to maxheight... |
| set nitems [$widgets(listbox) size] |
| if {$nitems > $options(-maxheight)} { |
| # tweak the height of the listbox |
| $widgets(listbox) configure -height $options(-maxheight) |
| } else { |
| # un-tweak the height of the listbox |
| $widgets(listbox) configure -height 0 |
| } |
| update idletasks |
| } |
| |
| # compute height and width of the dropdown list |
| set bd [$widgets(dropdown) cget -borderwidth] |
| set height [expr {[winfo reqheight $widgets(dropdown)] + $bd + $bd}] |
| if {[string length $options(-dropdownwidth)] == 0 || |
| $options(-dropdownwidth) == 0} { |
| set width [winfo width $widgets(this)] |
| } else { |
| set m [font measure [$widgets(listbox) cget -font] "m"] |
| set width [expr {$options(-dropdownwidth) * $m}] |
| } |
| |
| # figure out where to place it on the screen, trying to take into |
| # account we may be running under some virtual window manager |
| set screenWidth [winfo screenwidth $widgets(this)] |
| set screenHeight [winfo screenheight $widgets(this)] |
| set rootx [winfo rootx $widgets(this)] |
| set rooty [winfo rooty $widgets(this)] |
| set vrootx [winfo vrootx $widgets(this)] |
| set vrooty [winfo vrooty $widgets(this)] |
| |
| # the x coordinate is simply the rootx of our widget, adjusted for |
| # the virtual window. We won't worry about whether the window will |
| # be offscreen to the left or right -- we want the illusion that it |
| # is part of the entry widget, so if part of the entry widget is off- |
| # screen, so will the list. If you want to change the behavior, |
| # simply change the if statement... (and be sure to update this |
| # comment!) |
| set x [expr {$rootx + $vrootx}] |
| if {0} { |
| set rightEdge [expr {$x + $width}] |
| if {$rightEdge > $screenWidth} { |
| set x [expr {$screenWidth - $width}] |
| } |
| if {$x < 0} {set x 0} |
| } |
| |
| # the y coordinate is the rooty plus vrooty offset plus |
| # the height of the static part of the widget plus 1 for a |
| # tiny bit of visual separation... |
| set y [expr {$rooty + $vrooty + [winfo reqheight $widgets(this)] + 1}] |
| set bottomEdge [expr {$y + $height}] |
| |
| if {$bottomEdge >= $screenHeight} { |
| # ok. Fine. Pop it up above the entry widget isntead of |
| # below. |
| set y [expr {($rooty - $height - 1) + $vrooty}] |
| |
| if {$y < 0} { |
| # this means it extends beyond our screen. How annoying. |
| # Now we'll try to be real clever and either pop it up or |
| # down, depending on which way gives us the biggest list. |
| # then, we'll trim the list to fit and force the use of |
| # a scrollbar |
| |
| # (sadly, for windows users this measurement doesn't |
| # take into consideration the height of the taskbar, |
| # but don't blame me -- there isn't any way to detect |
| # it or figure out its dimensions. The same probably |
| # applies to any window manager with some magic windows |
| # glued to the top or bottom of the screen) |
| |
| if {$rooty > [expr {$screenHeight / 2}]} { |
| # we are in the lower half of the screen -- |
| # pop it up. Y is zero; that parts easy. The height |
| # is simply the y coordinate of our widget, minus |
| # a pixel for some visual separation. The y coordinate |
| # will be the topof the screen. |
| set y 1 |
| set height [expr {$rooty - 1 - $y}] |
| |
| } else { |
| # we are in the upper half of the screen -- |
| # pop it down |
| set y [expr {$rooty + $vrooty + \ |
| [winfo reqheight $widgets(this)] + 1}] |
| set height [expr {$screenHeight - $y}] |
| |
| } |
| |
| # force a scrollbar |
| HandleScrollbar $widgets(this) crop |
| } |
| } |
| |
| if {$y < 0} { |
| # hmmm. Bummer. |
| set y 0 |
| set height $screenheight |
| } |
| |
| set geometry [format "=%dx%d+%d+%d" $width $height $x $y] |
| |
| return $geometry |
| } |
| |
| # ::combobox::DoInternalWidgetCommand -- |
| # |
| # perform an internal widget command, then mung any error results |
| # to look like it came from our megawidget. A lot of work just to |
| # give the illusion that our megawidget is an atomic widget |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # subwidget pathname of the subwidget |
| # command subwidget command to be executed |
| # args arguments to the command |
| # |
| # Returns: |
| # |
| # The result of the subwidget command, or an error |
| |
| proc ::combobox::DoInternalWidgetCommand {w subwidget command args} { |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| |
| set subcommand $command |
| set command [concat $widgets($subwidget) $command $args] |
| if {[catch $command result]} { |
| # replace the subwidget name with the megawidget name |
| regsub $widgets($subwidget) $result $widgets(this) result |
| |
| # replace specific instances of the subwidget command |
| # with our megawidget command |
| switch $subwidget,$subcommand { |
| listbox,index {regsub "index" $result "list index" result} |
| listbox,insert {regsub "insert" $result "list insert" result} |
| listbox,delete {regsub "delete" $result "list delete" result} |
| listbox,get {regsub "get" $result "list get" result} |
| listbox,size {regsub "size" $result "list size" result} |
| } |
| error $result |
| |
| } else { |
| return $result |
| } |
| } |
| |
| |
| # ::combobox::WidgetProc -- |
| # |
| # This gets uses as the widgetproc for an combobox widget. |
| # Notice where the widget is created and you'll see that the |
| # actual widget proc merely evals this proc with all of the |
| # arguments intact. |
| # |
| # Note that some widget commands are defined "inline" (ie: |
| # within this proc), and some do most of their work in |
| # separate procs. This is merely because sometimes it was |
| # easier to do it one way or the other. |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # command widget subcommand |
| # args additional arguments; varies with the subcommand |
| # |
| # Results: |
| # |
| # Performs the requested widget command |
| |
| proc ::combobox::WidgetProc {w command args} { |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| upvar ::combobox::${w}::oldFocus oldFocus |
| upvar ::combobox::${w}::oldFocus oldGrab |
| |
| set command [::combobox::Canonize $w command $command] |
| |
| # this is just shorthand notation... |
| set doWidgetCommand \ |
| [list ::combobox::DoInternalWidgetCommand $widgets(this)] |
| |
| if {$command == "list"} { |
| # ok, the next argument is a list command; we'll |
| # rip it from args and append it to command to |
| # create a unique internal command |
| # |
| # NB: because of the sloppy way we are doing this, |
| # we'll also let the user enter our secret command |
| # directly (eg: listinsert, listdelete), but we |
| # won't document that fact |
| set command "list-[lindex $args 0]" |
| set args [lrange $args 1 end] |
| } |
| |
| set result "" |
| |
| # many of these commands are just synonyms for specific |
| # commands in one of the subwidgets. We'll get them out |
| # of the way first, then do the custom commands. |
| switch $command { |
| bbox - |
| delete - |
| get - |
| icursor - |
| index - |
| insert - |
| scan - |
| selection - |
| xview { |
| set result [eval $doWidgetCommand entry $command $args] |
| } |
| list-get {set result [eval $doWidgetCommand listbox get $args]} |
| list-index {set result [eval $doWidgetCommand listbox index $args]} |
| list-size {set result [eval $doWidgetCommand listbox size $args]} |
| |
| entryset { |
| # update the entry field without invoking the command |
| ::combobox::SetValue $widgets(this) [lindex $args 0] 0 |
| } |
| |
| select { |
| if {[llength $args] == 1} { |
| set index [lindex $args 0] |
| set result [Select $widgets(this) $index] |
| } else { |
| error "usage: $w select index" |
| } |
| } |
| |
| subwidget { |
| set knownWidgets [list button entry listbox dropdown vsb] |
| if {[llength $args] == 0} { |
| return $knownWidgets |
| } |
| |
| set name [lindex $args 0] |
| if {[lsearch $knownWidgets $name] != -1} { |
| set result $widgets($name) |
| } else { |
| error "unknown subwidget $name" |
| } |
| } |
| |
| curselection { |
| set result [eval $doWidgetCommand listbox curselection] |
| } |
| |
| list-insert { |
| eval $doWidgetCommand listbox insert $args |
| set result [HandleScrollbar $w "grow"] |
| } |
| |
| list-delete { |
| eval $doWidgetCommand listbox delete $args |
| set result [HandleScrollbar $w "shrink"] |
| } |
| |
| toggle { |
| # ignore this command if the widget is disabled... |
| if {$options(-state) == "disabled"} return |
| |
| # pops down the list if it is not, hides it |
| # if it is... |
| if {[winfo ismapped $widgets(dropdown)]} { |
| set result [$widgets(this) close] |
| } else { |
| set result [$widgets(this) open] |
| } |
| } |
| |
| open { |
| |
| # if this is an editable combobox, the focus should |
| # be set to the entry widget |
| if {$options(-editable)} { |
| focus $widgets(entry) |
| $widgets(entry) select range 0 end |
| $widgets(entry) icursor end |
| } |
| |
| # if we are disabled, we won't allow this to happen |
| if {$options(-state) == "disabled"} { |
| return 0 |
| } |
| |
| # if there is a -opencommand, execute it now |
| if {[string length $options(-opencommand)] > 0} { |
| # hmmm... should I do a catch, or just let the normal |
| # error handling handle any errors? For now, the latter... |
| uplevel \#0 $options(-opencommand) |
| } |
| |
| # compute the geometry of the window to pop up, and set |
| # it, and force the window manager to take notice |
| # (even if it is not presently visible). |
| # |
| # this isn't strictly necessary if the window is already |
| # mapped, but we'll go ahead and set the geometry here |
| # since its harmless and *may* actually reset the geometry |
| # to something better in some weird case. |
| set geometry [::combobox::ComputeGeometry $widgets(this)] |
| wm geometry $widgets(dropdown) $geometry |
| update idletasks |
| |
| # if we are already open, there's nothing else to do |
| if {[winfo ismapped $widgets(dropdown)]} { |
| return 0 |
| } |
| |
| # save the widget that currently has the focus; we'll restore |
| # the focus there when we're done |
| set oldFocus [focus] |
| |
| # ok, tweak the visual appearance of things and |
| # make the list pop up |
| $widgets(button) configure -relief sunken |
| wm deiconify $widgets(dropdown) |
| update idletasks |
| raise $widgets(dropdown) |
| |
| # force focus to the entry widget so we can handle keypress |
| # events for traversal |
| focus -force $widgets(entry) |
| |
| # select something by default, but only if its an |
| # exact match... |
| ::combobox::Find $widgets(this) 1 |
| |
| # save the current grab state for the display containing |
| # this widget. We'll restore it when we close the dropdown |
| # list |
| set status "none" |
| set grab [grab current $widgets(this)] |
| if {$grab != ""} {set status [grab status $grab]} |
| set oldGrab [list $grab $status] |
| unset grab status |
| |
| # *gasp* do a global grab!!! Mom always told me not to |
| # do things like this, but sometimes a man's gotta do |
| # what a man's gotta do. |
| grab -global $widgets(this) |
| |
| # fake the listbox into thinking it has focus. This is |
| # necessary to get scanning initialized properly in the |
| # listbox. |
| event generate $widgets(listbox) <B1-Enter> |
| |
| return 1 |
| } |
| |
| close { |
| # if we are already closed, don't do anything... |
| if {![winfo ismapped $widgets(dropdown)]} { |
| return 0 |
| } |
| |
| # restore the focus and grab, but ignore any errors... |
| # we're going to be paranoid and release the grab before |
| # trying to set any other grab because we really really |
| # really want to make sure the grab is released. |
| catch {focus $oldFocus} result |
| catch {grab release $widgets(this)} |
| catch { |
| set status [lindex $oldGrab 1] |
| if {$status == "global"} { |
| grab -global [lindex $oldGrab 0] |
| } elseif {$status == "local"} { |
| grab [lindex $oldGrab 0] |
| } |
| unset status |
| } |
| |
| # hides the listbox |
| $widgets(button) configure -relief raised |
| wm withdraw $widgets(dropdown) |
| |
| # select the data in the entry widget. Not sure |
| # why, other than observation seems to suggest that's |
| # what windows widgets do. |
| set editable [::combobox::GetBoolean $options(-editable)] |
| if {$editable} { |
| $widgets(entry) selection range 0 end |
| $widgets(button) configure -relief raised |
| } |
| |
| |
| # magic tcl stuff (see tk.tcl in the distribution |
| # lib directory) |
| ::combobox::tkCancelRepeat |
| |
| return 1 |
| } |
| |
| cget { |
| if {[llength $args] != 1} { |
| error "wrong # args: should be $w cget option" |
| } |
| set opt [::combobox::Canonize $w option [lindex $args 0]] |
| |
| if {$opt == "-value"} { |
| set result [$widgets(entry) get] |
| } else { |
| set result $options($opt) |
| } |
| } |
| |
| configure { |
| set result [eval ::combobox::Configure {$w} $args] |
| } |
| |
| default { |
| error "bad option \"$command\"" |
| } |
| } |
| |
| return $result |
| } |
| |
| # ::combobox::Configure -- |
| # |
| # Implements the "configure" widget subcommand |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # args zero or more option/value pairs (or a single option) |
| # |
| # Results: |
| # |
| # Performs typcial "configure" type requests on the widget |
| |
| proc ::combobox::Configure {w args} { |
| variable widgetOptions |
| variable defaultEntryCursor |
| |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| |
| if {[llength $args] == 0} { |
| # hmmm. User must be wanting all configuration information |
| # note that if the value of an array element is of length |
| # one it is an alias, which needs to be handled slightly |
| # differently |
| set results {} |
| foreach opt [lsort [array names widgetOptions]] { |
| if {[llength $widgetOptions($opt)] == 1} { |
| set alias $widgetOptions($opt) |
| set optName $widgetOptions($alias) |
| lappend results [list $opt $optName] |
| } else { |
| set optName [lindex $widgetOptions($opt) 0] |
| set optClass [lindex $widgetOptions($opt) 1] |
| set default [option get $w $optName $optClass] |
| if {[info exists options($opt)]} { |
| lappend results [list $opt $optName $optClass \ |
| $default $options($opt)] |
| } else { |
| lappend results [list $opt $optName $optClass \ |
| $default ""] |
| } |
| } |
| } |
| |
| return $results |
| } |
| |
| # one argument means we are looking for configuration |
| # information on a single option |
| if {[llength $args] == 1} { |
| set opt [::combobox::Canonize $w option [lindex $args 0]] |
| |
| set optName [lindex $widgetOptions($opt) 0] |
| set optClass [lindex $widgetOptions($opt) 1] |
| set default [option get $w $optName $optClass] |
| set results [list $opt $optName $optClass \ |
| $default $options($opt)] |
| return $results |
| } |
| |
| # if we have an odd number of values, bail. |
| if {[expr {[llength $args]%2}] == 1} { |
| # hmmm. An odd number of elements in args |
| error "value for \"[lindex $args end]\" missing" |
| } |
| |
| # Great. An even number of options. Let's make sure they |
| # are all valid before we do anything. Note that Canonize |
| # will generate an error if it finds a bogus option; otherwise |
| # it returns the canonical option name |
| foreach {name value} $args { |
| set name [::combobox::Canonize $w option $name] |
| set opts($name) $value |
| } |
| |
| # process all of the configuration options |
| # some (actually, most) options require us to |
| # do something, like change the attributes of |
| # a widget or two. Here's where we do that... |
| # |
| # note that the handling of disabledforeground and |
| # disabledbackground is a little wonky. First, we have |
| # to deal with backwards compatibility (ie: tk 8.3 and below |
| # didn't have such options for the entry widget), and |
| # we have to deal with the fact we might want to disable |
| # the entry widget but use the normal foreground/background |
| # for when the combobox is not disabled, but not editable either. |
| |
| set updateVisual 0 |
| foreach option [array names opts] { |
| set newValue $opts($option) |
| if {[info exists options($option)]} { |
| set oldValue $options($option) |
| } |
| |
| switch -- $option { |
| -buttonbackground { |
| $widgets(button) configure -background $newValue |
| } |
| -background { |
| set updateVisual 1 |
| set options($option) $newValue |
| } |
| |
| -borderwidth { |
| $widgets(frame) configure -borderwidth $newValue |
| set options($option) $newValue |
| } |
| |
| -command { |
| # nothing else to do... |
| set options($option) $newValue |
| } |
| |
| -commandstate { |
| # do some value checking... |
| if {$newValue != "normal" && $newValue != "disabled"} { |
| set options($option) $oldValue |
| set message "bad state value \"$newValue\";" |
| append message " must be normal or disabled" |
| error $message |
| } |
| set options($option) $newValue |
| } |
| |
| -cursor { |
| $widgets(frame) configure -cursor $newValue |
| $widgets(entry) configure -cursor $newValue |
| $widgets(listbox) configure -cursor $newValue |
| set options($option) $newValue |
| } |
| |
| -disabledforeground { |
| set updateVisual 1 |
| set options($option) $newValue |
| } |
| |
| -disabledbackground { |
| set updateVisual 1 |
| set options($option) $newValue |
| } |
| |
| -dropdownwidth { |
| set options($option) $newValue |
| } |
| |
| -editable { |
| set updateVisual 1 |
| if {$newValue} { |
| # it's editable... |
| $widgets(entry) configure \ |
| -state normal \ |
| -cursor $defaultEntryCursor |
| } else { |
| $widgets(entry) configure \ |
| -state disabled \ |
| -cursor $options(-cursor) |
| } |
| set options($option) $newValue |
| } |
| |
| -elementborderwidth { |
| $widgets(button) configure -borderwidth $newValue |
| $widgets(vsb) configure -borderwidth $newValue |
| $widgets(dropdown) configure -borderwidth $newValue |
| set options($option) $newValue |
| } |
| |
| -font { |
| $widgets(entry) configure -font $newValue |
| $widgets(listbox) configure -font $newValue |
| set options($option) $newValue |
| } |
| |
| -foreground { |
| set updateVisual 1 |
| set options($option) $newValue |
| } |
| |
| -height { |
| $widgets(listbox) configure -height $newValue |
| HandleScrollbar $w |
| set options($option) $newValue |
| } |
| |
| -highlightbackground { |
| $widgets(frame) configure -highlightbackground $newValue |
| set options($option) $newValue |
| } |
| |
| -highlightcolor { |
| $widgets(frame) configure -highlightcolor $newValue |
| set options($option) $newValue |
| } |
| |
| -highlightthickness { |
| $widgets(frame) configure -highlightthickness $newValue |
| set options($option) $newValue |
| } |
| |
| -image { |
| if {[string length $newValue] > 0} { |
| puts "old button width: [$widgets(button) cget -width]" |
| $widgets(button) configure \ |
| -image $newValue \ |
| -width [expr {[image width $newValue] + 2}] |
| puts "new button width: [$widgets(button) cget -width]" |
| |
| } else { |
| $widgets(button) configure -image ::combobox::bimage |
| } |
| set options($option) $newValue |
| } |
| |
| -listvar { |
| if {[catch {$widgets(listbox) cget -listvar}]} { |
| return -code error \ |
| "-listvar not supported with this version of tk" |
| } |
| $widgets(listbox) configure -listvar $newValue |
| set options($option) $newValue |
| } |
| |
| -maxheight { |
| # ComputeGeometry may dork with the actual height |
| # of the listbox, so let's undork it |
| $widgets(listbox) configure -height $options(-height) |
| HandleScrollbar $w |
| set options($option) $newValue |
| } |
| |
| -opencommand { |
| # nothing else to do... |
| set options($option) $newValue |
| } |
| |
| -relief { |
| $widgets(frame) configure -relief $newValue |
| set options($option) $newValue |
| } |
| |
| -selectbackground { |
| $widgets(entry) configure -selectbackground $newValue |
| $widgets(listbox) configure -selectbackground $newValue |
| set options($option) $newValue |
| } |
| |
| -selectborderwidth { |
| $widgets(entry) configure -selectborderwidth $newValue |
| $widgets(listbox) configure -selectborderwidth $newValue |
| set options($option) $newValue |
| } |
| |
| -selectforeground { |
| $widgets(entry) configure -selectforeground $newValue |
| $widgets(listbox) configure -selectforeground $newValue |
| set options($option) $newValue |
| } |
| |
| -state { |
| if {$newValue == "normal"} { |
| set updateVisual 1 |
| # it's enabled |
| |
| set editable [::combobox::GetBoolean \ |
| $options(-editable)] |
| if {$editable} { |
| $widgets(entry) configure -state normal |
| $widgets(entry) configure -takefocus 1 |
| } |
| |
| # note that $widgets(button) is actually a label, |
| # not a button. And being able to disable labels |
| # wasn't possible until tk 8.3. (makes me wonder |
| # why I chose to use a label, but that answer is |
| # lost to antiquity) |
| if {[info patchlevel] >= 8.3} { |
| $widgets(button) configure -state normal |
| } |
| |
| } elseif {$newValue == "disabled"} { |
| set updateVisual 1 |
| # it's disabled |
| $widgets(entry) configure -state disabled |
| $widgets(entry) configure -takefocus 0 |
| # note that $widgets(button) is actually a label, |
| # not a button. And being able to disable labels |
| # wasn't possible until tk 8.3. (makes me wonder |
| # why I chose to use a label, but that answer is |
| # lost to antiquity) |
| if {$::tcl_version >= 8.3} { |
| $widgets(button) configure -state disabled |
| } |
| |
| } else { |
| set options($option) $oldValue |
| set message "bad state value \"$newValue\";" |
| append message " must be normal or disabled" |
| error $message |
| } |
| |
| set options($option) $newValue |
| } |
| |
| -takefocus { |
| $widgets(entry) configure -takefocus $newValue |
| set options($option) $newValue |
| } |
| |
| -textvariable { |
| $widgets(entry) configure -textvariable $newValue |
| set options($option) $newValue |
| } |
| |
| -value { |
| ::combobox::SetValue $widgets(this) $newValue |
| set options($option) $newValue |
| } |
| |
| -width { |
| $widgets(entry) configure -width $newValue |
| $widgets(listbox) configure -width $newValue |
| set options($option) $newValue |
| } |
| |
| -xscrollcommand { |
| $widgets(entry) configure -xscrollcommand $newValue |
| set options($option) $newValue |
| } |
| } |
| |
| if {$updateVisual} {UpdateVisualAttributes $w} |
| } |
| } |
| |
| # ::combobox::UpdateVisualAttributes -- |
| # |
| # sets the visual attributes (foreground, background mostly) |
| # based on the current state of the widget (normal/disabled, |
| # editable/non-editable) |
| # |
| # why a proc for such a simple thing? Well, in addition to the |
| # various states of the widget, we also have to consider the |
| # version of tk being used -- versions from 8.4 and beyond have |
| # the notion of disabled foreground/background options for various |
| # widgets. All of the permutations can get nasty, so we encapsulate |
| # it all in one spot. |
| # |
| # note also that we don't handle all visual attributes here; just |
| # the ones that depend on the state of the widget. The rest are |
| # handled on a case by case basis |
| # |
| # Arguments: |
| # w widget pathname |
| # |
| # Returns: |
| # empty string |
| |
| proc ::combobox::UpdateVisualAttributes {w} { |
| |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| |
| if {$options(-state) == "normal"} { |
| |
| set foreground $options(-foreground) |
| set background $options(-background) |
| |
| } elseif {$options(-state) == "disabled"} { |
| |
| set foreground $options(-disabledforeground) |
| set background $options(-disabledbackground) |
| } |
| |
| $widgets(entry) configure -foreground $foreground -background $background |
| $widgets(listbox) configure -foreground $foreground -background $background |
| $widgets(button) configure -foreground $foreground |
| $widgets(vsb) configure -background $background -troughcolor $background |
| $widgets(frame) configure -background $background |
| |
| # we need to set the disabled colors in case our widget is disabled. |
| # We could actually check for disabled-ness, but we also need to |
| # check whether we're enabled but not editable, in which case the |
| # entry widget is disabled but we still want the enabled colors. It's |
| # easier just to set everything and be done with it. |
| |
| if {$::tcl_version >= 8.4} { |
| $widgets(entry) configure \ |
| -disabledforeground $foreground \ |
| -disabledbackground $background |
| $widgets(button) configure -disabledforeground $foreground |
| $widgets(listbox) configure -disabledforeground $foreground |
| } |
| } |
| |
| # ::combobox::SetValue -- |
| # |
| # sets the value of the combobox and calls the -command, |
| # if defined |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # newValue the new value of the combobox |
| # |
| # Returns |
| # |
| # Empty string |
| |
| proc ::combobox::SetValue {w newValue {call 1}} { |
| |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| upvar ::combobox::${w}::ignoreTrace ignoreTrace |
| upvar ::combobox::${w}::oldValue oldValue |
| |
| if {[info exists options(-textvariable)] \ |
| && [string length $options(-textvariable)] > 0} { |
| set variable ::$options(-textvariable) |
| set $variable $newValue |
| } else { |
| set oldstate [$widgets(entry) cget -state] |
| $widgets(entry) configure -state normal |
| $widgets(entry) delete 0 end |
| $widgets(entry) insert 0 $newValue |
| $widgets(entry) configure -state $oldstate |
| } |
| |
| # set our internal textvariable; this will cause any public |
| # textvariable (ie: defined by the user) to be updated as |
| # well |
| # set ::combobox::${w}::entryTextVariable $newValue |
| |
| # redefine our concept of the "old value". Do it before running |
| # any associated command so we can be sure it happens even |
| # if the command somehow fails. |
| set oldValue $newValue |
| |
| |
| # call the associated command. The proc will handle whether or |
| # not to actually call it, and with what args |
| if {$call} { |
| CallCommand $w $newValue |
| } |
| |
| return "" |
| } |
| |
| # ::combobox::CallCommand -- |
| # |
| # calls the associated command, if any, appending the new |
| # value to the command to be called. |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # newValue the new value of the combobox |
| # |
| # Returns |
| # |
| # empty string |
| |
| proc ::combobox::CallCommand {w newValue} { |
| upvar ::combobox::${w}::widgets widgets |
| upvar ::combobox::${w}::options options |
| |
| # call the associated command, if defined and -commandstate is |
| # set to "normal" |
| if {$options(-commandstate) == "normal" && \ |
| [string length $options(-command)] > 0} { |
| set args [list $widgets(this) $newValue] |
| uplevel \#0 $options(-command) $args |
| } |
| } |
| |
| |
| # ::combobox::GetBoolean -- |
| # |
| # returns the value of a (presumably) boolean string (ie: it should |
| # do the right thing if the string is "yes", "no", "true", 1, etc |
| # |
| # Arguments: |
| # |
| # value value to be converted |
| # errorValue a default value to be returned in case of an error |
| # |
| # Returns: |
| # |
| # a 1 or zero, or the value of errorValue if the string isn't |
| # a proper boolean value |
| |
| proc ::combobox::GetBoolean {value {errorValue 1}} { |
| if {[catch {expr {([string trim $value])?1:0}} res]} { |
| return $errorValue |
| } else { |
| return $res |
| } |
| } |
| |
| # ::combobox::convert -- |
| # |
| # public routine to convert %x, %y and %W binding substitutions. |
| # Given an x, y and or %W value relative to a given widget, this |
| # routine will convert the values to be relative to the combobox |
| # widget. For example, it could be used in a binding like this: |
| # |
| # bind .combobox <blah> {doSomething [::combobox::convert %W -x %x]} |
| # |
| # Note that this procedure is *not* exported, but is intended for |
| # public use. It is not exported because the name could easily |
| # clash with existing commands. |
| # |
| # Arguments: |
| # |
| # w a widget path; typically the actual result of a %W |
| # substitution in a binding. It should be either a |
| # combobox widget or one of its subwidgets |
| # |
| # args should one or more of the following arguments or |
| # pairs of arguments: |
| # |
| # -x <x> will convert the value <x>; typically <x> will |
| # be the result of a %x substitution |
| # -y <y> will convert the value <y>; typically <y> will |
| # be the result of a %y substitution |
| # -W (or -w) will return the name of the combobox widget |
| # which is the parent of $w |
| # |
| # Returns: |
| # |
| # a list of the requested values. For example, a single -w will |
| # result in a list of one items, the name of the combobox widget. |
| # Supplying "-x 10 -y 20 -W" (in any order) will return a list of |
| # three values: the converted x and y values, and the name of |
| # the combobox widget. |
| |
| proc ::combobox::convert {w args} { |
| set result {} |
| if {![winfo exists $w]} { |
| error "window \"$w\" doesn't exist" |
| } |
| |
| while {[llength $args] > 0} { |
| set option [lindex $args 0] |
| set args [lrange $args 1 end] |
| |
| switch -exact -- $option { |
| -x { |
| set value [lindex $args 0] |
| set args [lrange $args 1 end] |
| set win $w |
| while {[winfo class $win] != "Combobox"} { |
| incr value [winfo x $win] |
| set win [winfo parent $win] |
| if {$win == "."} break |
| } |
| lappend result $value |
| } |
| |
| -y { |
| set value [lindex $args 0] |
| set args [lrange $args 1 end] |
| set win $w |
| while {[winfo class $win] != "Combobox"} { |
| incr value [winfo y $win] |
| set win [winfo parent $win] |
| if {$win == "."} break |
| } |
| lappend result $value |
| } |
| |
| -w - |
| -W { |
| set win $w |
| while {[winfo class $win] != "Combobox"} { |
| set win [winfo parent $win] |
| if {$win == "."} break; |
| } |
| lappend result $win |
| } |
| } |
| } |
| return $result |
| } |
| |
| # ::combobox::Canonize -- |
| # |
| # takes a (possibly abbreviated) option or command name and either |
| # returns the canonical name or an error |
| # |
| # Arguments: |
| # |
| # w widget pathname |
| # object type of object to canonize; must be one of "command", |
| # "option", "scan command" or "list command" |
| # opt the option (or command) to be canonized |
| # |
| # Returns: |
| # |
| # Returns either the canonical form of an option or command, |
| # or raises an error if the option or command is unknown or |
| # ambiguous. |
| |
| proc ::combobox::Canonize {w object opt} { |
| variable widgetOptions |
| variable columnOptions |
| variable widgetCommands |
| variable listCommands |
| variable scanCommands |
| |
| switch $object { |
| command { |
| if {[lsearch -exact $widgetCommands $opt] >= 0} { |
| return $opt |
| } |
| |
| # command names aren't stored in an array, and there |
| # isn't a way to get all the matches in a list, so |
| # we'll stuff the commands in a temporary array so |
| # we can use [array names] |
| set list $widgetCommands |
| foreach element $list { |
| set tmp($element) "" |
| } |
| set matches [array names tmp ${opt}*] |
| } |
| |
| {list command} { |
| if {[lsearch -exact $listCommands $opt] >= 0} { |
| return $opt |
| } |
| |
| # command names aren't stored in an array, and there |
| # isn't a way to get all the matches in a list, so |
| # we'll stuff the commands in a temporary array so |
| # we can use [array names] |
| set list $listCommands |
| foreach element $list { |
| set tmp($element) "" |
| } |
| set matches [array names tmp ${opt}*] |
| } |
| |
| {scan command} { |
| if {[lsearch -exact $scanCommands $opt] >= 0} { |
| return $opt |
| } |
| |
| # command names aren't stored in an array, and there |
| # isn't a way to get all the matches in a list, so |
| # we'll stuff the commands in a temporary array so |
| # we can use [array names] |
| set list $scanCommands |
| foreach element $list { |
| set tmp($element) "" |
| } |
| set matches [array names tmp ${opt}*] |
| } |
| |
| option { |
| if {[info exists widgetOptions($opt)] \ |
| && [llength $widgetOptions($opt)] == 2} { |
| return $opt |
| } |
| set list [array names widgetOptions] |
| set matches [array names widgetOptions ${opt}*] |
| } |
| |
| } |
| |
| if {[llength $matches] == 0} { |
| set choices [HumanizeList $list] |
| error "unknown $object \"$opt\"; must be one of $choices" |
| |
| } elseif {[llength $matches] == 1} { |
| set opt [lindex $matches 0] |
| |
| # deal with option aliases |
| switch $object { |
| option { |
| set opt [lindex $matches 0] |
| if {[llength $widgetOptions($opt)] == 1} { |
| set opt $widgetOptions($opt) |
| } |
| } |
| } |
| |
| return $opt |
| |
| } else { |
| set choices [HumanizeList $list] |
| error "ambiguous $object \"$opt\"; must be one of $choices" |
| } |
| } |
| |
| # ::combobox::HumanizeList -- |
| # |
| # Returns a human-readable form of a list by separating items |
| # by columns, but separating the last two elements with "or" |
| # (eg: foo, bar or baz) |
| # |
| # Arguments: |
| # |
| # list a valid tcl list |
| # |
| # Results: |
| # |
| # A string which as all of the elements joined with ", " or |
| # the word " or " |
| |
| proc ::combobox::HumanizeList {list} { |
| |
| if {[llength $list] == 1} { |
| return [lindex $list 0] |
| } else { |
| set list [lsort $list] |
| set secondToLast [expr {[llength $list] -2}] |
| set most [lrange $list 0 $secondToLast] |
| set last [lindex $list end] |
| |
| return "[join $most {, }] or $last" |
| } |
| } |
| |
| # This is some backwards-compatibility code to handle TIP 44 |
| # (http://purl.org/tcl/tip/44.html). For all private tk commands |
| # used by this widget, we'll make duplicates of the procs in the |
| # combobox namespace. |
| # |
| # I'm not entirely convinced this is the right thing to do. I probably |
| # shouldn't even be using the private commands. Then again, maybe the |
| # private commands really should be public. Oh well; it works so it |
| # must be OK... |
| foreach command {TabToWindow CancelRepeat ListboxUpDown} { |
| if {[llength [info commands ::combobox::tk$command]] == 1} break; |
| |
| set tmp [info commands tk$command] |
| set proc ::combobox::tk$command |
| if {[llength [info commands tk$command]] == 1} { |
| set command [namespace which [lindex $tmp 0]] |
| proc $proc {args} "uplevel $command \$args" |
| } else { |
| if {[llength [info commands ::tk::$command]] == 1} { |
| proc $proc {args} "uplevel ::tk::$command \$args" |
| } |
| } |
| } |
| |
| # end of combobox.tcl |
| |