-# Copyright (c) 1998, Bryan Oakley
+# Copyright (c) 1998-2002, Bryan Oakley
# All Rights Reservered
#
# Bryan Oakley
-# oakley@channelpoint.com
+# oakley@bardo.clearlight.com
#
-# combobox v1.05 August 17, 1998
-# a dropdown combobox widget
+# combobox v2.2.1 September 22, 2002
#
-# this code is freely distributable without restriction, but is
-# provided as-is with no waranty expressed or implied.
-#
-# Standard Options:
-#
-# -background -borderwidth -font -foreground -highlightthickness
-# -highlightbackground -relief -state -textvariable
-# -selectbackground -selectborderwidth -selectforeground
-# -cursor
-#
-# Custom Options:
-# -command a command to run whenever the value is changed.
-# This command will be called with two values
-# appended to it -- the name of the widget and the
-# new value. It is run at the global scope.
-# -editable if true, user can type into edit box; false, she can't
-# -height specifies height of dropdown list, in lines
-# -image image for the button to pop down the list...
-# -maxheight specifies maximum height of dropdown list, in lines
-# -value duh
-# -width treated just like the -width option to entry widgets
+# 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.
#
-# widget commands:
-#
-# (see source... there's a bunch; duplicates of most of the entry
-# widget commands, plus commands to manipulate the listbox and a couple
-# unique to the combobox as a whole)
-#
-# to create a combobox:
-#
-# namespace import combobox::combobox
-# combobox .foo ?options?
+# 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
#
-# thanks to the following people who provided beta test support or
-# patches to the code:
+# 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.
#
-# Martin M. Hunt (hunt@cygnus.com)
+# ... and many others over the years.
package require Tk 8.0
-package provide combobox 1.05
+package provide combobox 2.2.1
namespace eval ::combobox {
- global tcl_platform
+
# this is the public interface
namespace export combobox
- if {$tcl_platform(platform) != "windows"} {
- set sbtest ". "
- radiobutton $sbtest
- set disabledfg [$sbtest cget -disabledforeground]
- set enabledfg [$sbtest cget -fg]
- } else {
- set disabledfg SystemDisabledText
- set enabledfg SystemWindowText
- }
+ # these contain references to available options
+ variable widgetOptions
- # the image used for the button...
- 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
- };
- }
+ # these contain references to available commands and subcommands
+ variable widgetCommands
+ variable scanCommands
+ variable listCommands
}
-# this is the command that gets exported, and creates a new
-# combobox widget. It works like other widget commands in that
-# it takes as its first argument a widget path, and any remaining
-# arguments are option/value pairs for the widget
+# ::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
+ eval Build $w $args
# set some bindings...
- setBindings $w
+ SetBindings $w
# and we are done!
return $w
}
-# builds the combobox...
-proc ::combobox::build {w args } {
- global tcl_platform
+
+# ::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} \
+ -command {command Command} \
+ -commandstate {commandState State} \
+ -cursor {cursor Cursor} \
+ -disabledbackground {disabledBackground DisabledBackground} \
+ -disabledforeground {disabledForeground DisabledForeground} \
+ -dropdownwidth {dropdownWidth DropdownWidth} \
+ -editable {editable Editable} \
+ -fg -foreground \
+ -font {font Font} \
+ -foreground {foreground Foreground} \
+ -height {height Height} \
+ -highlightbackground {highlightBackground HighlightBackground} \
+ -highlightcolor {highlightColor HighlightColor} \
+ -highlightthickness {highlightThickness HighlightThickness} \
+ -image {image Image} \
+ -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 \
+ ]
+
+ 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]
+ 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.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...
+ # create the namespace for this instance, and define a few
+ # variables
namespace eval ::combobox::$w {
- variable widgets
+ variable ignoreTrace 0
+ variable oldFocus {}
+ variable oldGrab {}
+ variable oldValue {}
variable options
- variable oldValue
- variable ignoreTrace
- variable grablist
- variable grabstatus
variable this
+ variable widgets
- array set widgets {}
- array set options {}
+ set widgets(foo) foo ;# coerce into an array
+ set options(foo) foo ;# coerce into an array
- set oldValue {}
- set ignoreTrace 0
+ unset widgets(foo)
+ unset options(foo)
}
- # import the widgets and options arrays into this proc
+ # 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
- # ok, everything we create should exist in the namespace
- # we create for this widget. This is to hide all the internal
- # foo from prying eyes. If they really want to get at the
- # internals, they know where they can find it...
+ # 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
+ }
- # see... I'm pretending to be a Java programmer here...
- set this $w
- namespace eval ::combobox::$w "set this $this"
+ # 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)
+ }
- # the basic, always-visible parts of the combobox. We do these
- # here, because we want to query some of them for their default
- # values, which we want to juggle to other widgets. I suppose
- # I could use the options database, but I choose not to...
- set widgets(this) [frame $this -class Combobox -takefocus 0]
- set widgets(entry) [entry $this.entry -takefocus {}]
- set widgets(button) [label $this.button -takefocus 0]
+ # 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 store it here...
- set widgets(frame) .$this
-
- pack $widgets(button) -side right -fill y -expand n
- pack $widgets(entry) -side left -fill both -expand y
-
- # we need these to be defined, regardless if the user defined
- # them for us or not...
- array set options [list \
- -height 0 \
- -maxheight 10 \
- -command {} \
- -image {} \
- -textvariable {} \
- -editable 1 \
- -state normal
- ]
- # now, steal some attributes from the entry widget...
- foreach option [list -background -foreground -relief \
- -borderwidth -highlightthickness -highlightbackground \
- -font -width -selectbackground -selectborderwidth \
- -selectforeground] {
- set options($option) [$widgets(entry) cget $option]
- }
+ # 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(entry) -side left -fill both -expand yes
+ pack $widgets(button) -side right -fill y -expand no
# I should probably do this in a catch, but for now it's
# good enough... What it does, obviously, is put all of
# now, the dropdown list... the same renaming nonsense
# must go on here as well...
- set widgets(popup) [toplevel $this.top]
- set widgets(listbox) [listbox $this.top.list]
- set widgets(vsb) [scrollbar $this.top.vsb]
+ 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
# 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.
+ # flat. This makes the button which drops down the list
+ # to appear "inside" the entry widget.
+
$widgets(vsb) configure \
-command "$widgets(listbox) yview" \
-highlightthickness 0
- set width [expr [winfo reqwidth $widgets(vsb)] - 2]
$widgets(button) configure \
-highlightthickness 0 \
-borderwidth 1 \
-relief raised \
- -width $width
+ -width [expr {[winfo reqwidth $widgets(vsb)] - 2}]
$widgets(entry) configure \
-borderwidth 0 \
-relief flat \
-highlightthickness 0
- $widgets(popup) configure \
+ $widgets(dropdown) configure \
-borderwidth 1 \
-relief sunken
+
$widgets(listbox) configure \
-selectmode browse \
-background [$widgets(entry) cget -bg] \
-yscrollcommand "$widgets(vsb) set" \
+ -exportselection false \
-borderwidth 0
- #Windows look'n'feel: black boarder around listbox
- if {$tcl_platform(platform)=="windows"} {
- $widgets(listbox) configure -highlightbackground black
- }
-
- # do some window management foo.
- wm overrideredirect $widgets(popup) 1
- wm transient $widgets(popup) [winfo toplevel $this]
- wm group $widgets(popup) [winfo parent $this]
- wm resizable $widgets(popup) 0 0
- wm withdraw $widgets(popup)
+# 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 ::$this $widgets(frame)
+ rename ::$w $widgets(frame)
# now, create our widget proc. Obviously (?) it goes in
- # the global namespace
-
- proc ::$this {command args} \
- "eval ::combobox::widgetProc $this \$command \$args"
-# namespace export $this
-# uplevel \#0 namespace import ::combobox::${this}::$this
-
- # ok, the thing exists... let's do a bit more configuration:
- foreach opt [array names options] {
- ::combobox::configure $widgets(this) set $opt $options($opt)
- }
-}
+ # 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"
-# 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...
-proc ::combobox::setBindings {w} {
- namespace eval ::combobox::$w {
- variable widgets
- variable options
- # make sure we clean up after ourselves...
- bind $widgets(this) <Destroy> [list ::combobox::destroyHandler $this]
-
- # this closes the listbox if we get hidden
- bind $widgets(this) <Unmap> "$widgets(this) close"
-
- # this helps (but doesn't fully solve) focus issues.
- bind $widgets(this) <FocusIn> [list focus $widgets(entry)]
-
- # 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(entry) <FocusIn> \
- [list ::combobox::entryFocus $widgets(this) "<FocusIn>"]
- bind $widgets(entry) <FocusOut> \
- [list ::combobox::entryFocus $widgets(this) "<FocusOut>"]
-
- # 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
- bind $widgets(this) <Any-ButtonPress> [list $widgets(this) close]
- bind $widgets(this) <Any-ButtonRelease> [list $widgets(this) close]
-
- bind $widgets(listbox) <ButtonRelease-1> \
- "::combobox::select $widgets(this) \[$widgets(listbox) nearest %y\]; break"
-
- 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?)
- }
+ # 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"
+ }
- # these events need to be passed from the entry
- # widget to the listbox, or 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 \
- "::combobox::handleEvent $widgets(this) $event"
- }
+ return ""
- }
}
-# 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)
-proc ::combobox::handleEvent {w event} {
+# ::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
# 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>" {
- set editable [::combobox::getBoolean $options(-editable)]
# 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 {$editable} {
+ if {$options(-editable)} {
$widgets(listbox) see 0
$widgets(listbox) selection clear 0 end
$widgets(listbox) selection anchor 0
}
"<FocusOut>" {
- $widgets(entry) delete 0 end
- $widgets(entry) insert 0 $oldValue
+ 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)]
+ set editable [::combobox::GetBoolean $options(-editable)]
if {!$editable} {
- if {[winfo ismapped $widgets(popup)]} {
+ if {[winfo ismapped $widgets(dropdown)]} {
$widgets(this) close
return -code break;
return -code break;
}
}
+
"<Tab>" {
- if {[winfo ismapped $widgets(popup)]} {
- ::combobox::find $widgets(this)
+ 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(popup)]} {
+# $widgets(entry) delete 0 end
+# $widgets(entry) insert 0 $oldValue
+ if {[winfo ismapped $widgets(dropdown)]} {
$widgets(this) close
return -code break;
}
}
"<Return>" {
- set editable [::combobox::getBoolean $options(-editable)]
- if {$editable} {
- # if there is something in the list that is selected,
- # we'll pick it. Otherwise, use whats in the
- # entry widget...
- set index [$widgets(listbox) curselection]
- if {[winfo ismapped $widgets(popup)] && \
- [llength $index] > 0} {
-
- ::combobox::select $widgets(this) \
- [$widgets(listbox) curselection]
- return -code break;
-
- } else {
- ::combobox::setValue $widgets(this) [$widgets(this) get]
- $widgets(this) close
- return -code break;
- }
+ # did the value change?
+ set newValue [$widgets(entry) get]
+ if {$oldValue != $newValue} {
+ CallCommand $widgets(this) $newValue
}
- if {[winfo ismapped $widgets(popup)]} {
- ::combobox::select $widgets(this) \
+ if {[winfo ismapped $widgets(dropdown)]} {
+ ::combobox::Select $widgets(this) \
[$widgets(listbox) curselection]
return -code break;
}
}
"<Down>" {
- if {![winfo ismapped $widgets(popup)]} {
+ if {[winfo ismapped $widgets(dropdown)]} {
+ ::combobox::tkListboxUpDown $widgets(listbox) 1
+ return -code break;
+
+ } else {
if {$options(-state) != "disabled"} {
$widgets(this) open
return -code break;
}
- } else {
- tkListboxUpDown $widgets(listbox) 1
- return -code break;
}
}
"<Up>" {
- if {![winfo ismapped $widgets(popup)]} {
+ if {[winfo ismapped $widgets(dropdown)]} {
+ ::combobox::tkListboxUpDown $widgets(listbox) -1
+ return -code break;
+
+ } else {
if {$options(-state) != "disabled"} {
$widgets(this) open
return -code break;
}
- } else {
- tkListboxUpDown $widgets(listbox) -1
- return -code break;
}
}
}
-}
-
-# this cleans up the mess that is left behind when the widget goes away
-proc ::combobox::destroyHandler {w} {
-
- # kill any trace or after we may have started...
- namespace eval ::combobox::$w {
- variable options
- variable widgets
- if {[string length $options(-textvariable)]} {
- trace vdelete $options(-textvariable) w \
- [list ::combobox::vTrace $widgets(this)]
- }
-
- # CYGNUS LOCAL - kill any after command that may be registered.
- if {[info exists widgets(after)]} {
- after cancel $widgets(after)
- unset widgets(after)
- }
- }
+ return ""
+}
-# catch {rename ::combobox::${w}::$w {}}
- # kill the namespace
- catch {namespace delete ::combobox::$w}
+# ::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} {
+
+ # if the widget actually being destroyed is of class Combobox,
+ # crush the namespace and kill the proc. Get it? Crush. Kill.
+ # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it
+ # brings tears to my eyes.
+ if {[string compare [winfo class $w] "Combobox"] == 0} {
+ upvar ::combobox::${w}::widgets widgets
+ upvar ::combobox::${w}::options options
+
+ # delete the namespace and the proc which represents
+ # our widget
+ namespace delete ::combobox::$w
+ rename $w {}
+ }
+
+ return ""
}
-# finds something in the listbox that matches the pattern in the
-# entry widget
+# ::combobox::Find
+#
+# finds something in the listbox that matches the pattern in the
+# entry widget and selects it
#
-# 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...
-proc ::combobox::find {w {exact 0}} {
+# 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
# 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]
}
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
+ # unique WRT the second... I know there's probably a
# simpler way to do this...
- set nextIndex [expr $index + 1]
+ set nextIndex [expr {$index + 1}]
set nextItem [lindex $list $nextIndex]
# we don't really need to do much if the next
# 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
- } else {
+
+ } 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(listbox) selection anchor $index
$widgets(listbox) selection set $index
$widgets(listbox) see $index
+ $widgets(entry) configure -state $oldstate
}
}
-# selects an item from the list and sets the value of the combobox
-# to that value
-proc ::combobox::select {w index} {
+# ::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
- catch {
- set data [$widgets(listbox) get [lindex $index 0]]
- ::combobox::setValue $widgets(this) $data
+ # 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(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 $widgets(vsb) -side right -fill y -expand n
+ }
+ }
+
+ "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 $widgets(vsb) -side right -fill y -expand n
+ }
+
+ default {
+ if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} {
+ pack $widgets(vsb) -side right -fill y -expand n
+ } else {
+ pack forget $widgets(vsb)
+ }
+ }
+ }
+
+ return ""
}
-# computes the geometry of the popup list based on the size of the
-# combobox. Compute size of popup by requested size of listbox
-# plus twice the bordersize of the popup.
-proc ::combobox::computeGeometry {w} {
+# ::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
}
update idletasks
}
- set bd [$widgets(popup) cget -borderwidth]
- set height [expr [winfo reqheight $widgets(listbox)] + $bd + $bd]
- #set height [winfo reqheight $widgets(popup)]
-
- set width [winfo reqwidth $widgets(this)]
-
- # Compute size of listbox, allowing larger entries to expand
- # the listbox, clipped by the screen
- set x [winfo rootx $widgets(this)]
- set sw [winfo screenwidth $widgets(this)]
- if {$width > $sw - $x} {
- # The listbox will run off the side of the screen, so clip it
- # (and keep a 10 pixel margin).
- set width [expr {$sw - $x - 10}]
+
+ # 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
+ }
}
- set size [format "%dx%d" $width $height]
- set y [expr {[winfo rooty $widgets(this)]+[winfo reqheight $widgets(this)] + 1}]
- if {[expr $y + $height] >= [winfo screenheight .]} {
- set y [expr [winfo rooty $widgets(this)] - $height]
+
+ if {$y < 0} {
+ # hmmm. Bummer.
+ set y 0
+ set height $screenheight
}
- set location "+[winfo rootx $widgets(this)]+$y"
- set geometry "=${size}${location}"
+
+ set geometry [format "=%dx%d+%d+%d" $width $height $x $y]
+
return $geometry
}
-# 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
-proc ::combobox::doInternalWidgetCommand {w subwidget command args} {
+# ::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($w) result
+ regsub $widgets($subwidget) $result $widgets(this) result
# replace specific instances of the subwidget command
# with out megawidget command
listbox,delete {regsub "delete" $result "list delete" result}
listbox,get {regsub "get" $result "list get" result}
listbox,size {regsub "size" $result "list size" result}
- listbox,curselection {regsub "curselection" $result "list curselection" result}
}
error $result
}
-# this is the widget proc that gets called when you do something like
-# ".checkbox configure ..."
-proc ::combobox::widgetProc {w command args} {
+# ::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}::grablist grablist
- upvar ::combobox::${w}::grabstatus grabstatus
+ 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)]
+ [list ::combobox::DoInternalWidgetCommand $widgets(this)]
if {$command == "list"} {
# ok, the next argument is a list command; we'll
# 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 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 {eval $doWidgetCommand entry bbox $args}
- delete {eval $doWidgetCommand entry delete $args}
- get {eval $doWidgetCommand entry get $args}
- icursor {eval $doWidgetCommand entry icursor $args}
- index {eval $doWidgetCommand entry index $args}
- insert {eval $doWidgetCommand entry insert $args}
- listinsert {
- eval $doWidgetCommand listbox insert $args
- # pack the scrollbar if the number of items exceeds
- # the maximum
- if {$options(-height) == 0 && $options(-maxheight) != 0
- && ([$widgets(listbox) size] > $options(-maxheight))} {
- pack $widgets(vsb) -before $widgets(listbox) -side right \
- -fill y -expand n
- }
- }
- listdelete {
- eval $doWidgetCommand listbox delete $args
- # unpack the scrollbar if the number of items
- # decreases under the maximum
- if {$options(-height) == 0 && $options(-maxheight) != 0
- && ([$widgets(listbox) size] <= $options(-maxheight))} {
- pack forget $widgets(vsb)
- }
- }
- listget {eval $doWidgetCommand listbox get $args}
- listindex {eval $doWidgetCommand listbox index $args}
- listsize {eval $doWidgetCommand listbox size $args}
- listcurselection {eval $doWidgetCommand listbox curselection $args}
-
- scan {eval $doWidgetCommand entry scan $args}
- selection {eval $doWidgetCommand entry selection $args}
- xview {eval $doWidgetCommand entry xview $args}
+ 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
+ # 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 {
# pops down the list if it is not, hides it
# if it is...
- if {[winfo ismapped $widgets(popup)]} {
- $widgets(this) close
+ if {[winfo ismapped $widgets(dropdown)]} {
+ set result [$widgets(this) close]
} else {
- $widgets(this) open
+ 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) icur 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).
# 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(popup) $geometry
+ 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(popup)]} {
+ 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(popup)
- raise $widgets(popup) [winfo parent $widgets(this)]
+ raise $widgets(dropdown) [winfo parent $widgets(this)]
+ wm deiconify $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
-
- # *gasp* do a global grab!!! Mom always told not to
- # do things like this... :-)
- set grablist [grab current]
- set grabstatus {}
- foreach grabitem $grablist {
- lappend grabstatus [grab status $grabitem]
- }
+ ::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
+ # 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(popup)]} {
+ if {![winfo ismapped $widgets(dropdown)]} {
return 0
}
- # hides the listbox
- grab release $widgets(this)
- foreach grabitem $grablist itemstatus $grabstatus {
- if {$itemstatus == "global"} {
- grab set -global $grabitem
- } else {
- grab set $grabitem
+
+ # 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
}
- set grablist {}
- set grabstatus {}
+
+ # hides the listbox
$widgets(button) configure -relief raised
- wm withdraw $widgets(popup)
+ 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)]
+ 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)
- tk::CancelRepeat
+ ::combobox::tkCancelRepeat
return 1
}
cget {
- # tries to mimic the standard "cget" command
if {[llength $args] != 1} {
- error "wrong # args: should be \"$widgets(this) cget option\""
+ error "wrong # args: should be $w cget option"
}
- set option [lindex $args 0]
- return [::combobox::configure $widgets(this) cget $option]
- }
-
- configure {
- # trys to mimic the standard "configure" command
- if {[llength $args] == 0} {
- # this isn't the same format as "real" widgets,
- # but for now its good enough
- foreach item [lsort [array names options]] {
- lappend result [list $item $options($item)]
- }
- return $result
+ set opt [::combobox::Canonize $w option [lindex $args 0]]
- } elseif {[llength $args] == 1} {
- # they are requesting configure information...
- set option [lindex $args 0]
- return [::combobox::configure $widgets(this) get $option]
+ if {$opt == "-value"} {
+ set result [$widgets(entry) get]
} else {
- array set tmpopt $args
- foreach opt [array names tmpopt] {
- ::combobox::configure $widgets(this) set $opt $tmpopt($opt)
- }
+ set result $options($opt)
}
}
+
+ configure {
+ set result [eval ::combobox::Configure {$w} $args]
+ }
+
default {
error "bad option \"$command\""
}
}
+
+ return $result
}
-# handles all of the configure and cget foo
-proc ::combobox::configure {w action {option ""} {newValue ""}} {
+# ::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
- set namespace "::combobox::${w}"
-
- if {$action == "get"} {
- # this really ought to do more than just get the value,
- # but for the time being I don't fully support the configure
- # command in all its glory...
- if {$option == "-value"} {
- return [list "-value" [$widgets(entry) get]]
- } else {
- return [list $option $options($option)]
- }
- } elseif {$action == "cget"} {
- if {$option == "-value"} {
- return [$widgets(entry) get]
- } else {
- return $options($option)
+ 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 ""]
+ }
+ }
}
- } else {
+ 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)
- set options($option) $newValue
- } else {
- set oldValue ""
- set options($option) $newValue
}
- # some (actually, most) options require us to
- # do something, like change the attributes of
- # a widget or two. Here's where we do that...
switch -- $option {
-background {
- $widgets(frame) configure -background $newValue
- $widgets(entry) configure -background $newValue
- $widgets(listbox) configure -background $newValue
- $widgets(vsb) configure -background $newValue
- $widgets(vsb) configure -troughcolor $newValue
+ 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
+ $widgets(entry) configure \
+ -state normal \
+ -cursor $defaultEntryCursor
} else {
- $widgets(entry) configure -state disabled
+ $widgets(entry) configure \
+ -state disabled \
+ -cursor $options(-cursor)
}
+ set options($option) $newValue
}
-font {
$widgets(entry) configure -font $newValue
$widgets(listbox) configure -font $newValue
+ set options($option) $newValue
}
-foreground {
- $widgets(entry) configure -foreground $newValue
- $widgets(button) configure -foreground $newValue
- $widgets(listbox) configure -foreground $newValue
+ 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 {
} else {
$widgets(button) configure -image ::combobox::bimage
}
+ set options($option) $newValue
}
-maxheight {
- # computeGeometry may dork with the actual height
+ # 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 {
+ debug "newValue=$newValue"
if {$newValue == "normal"} {
+ set updateVisual 1
# it's enabled
- set editable [::combobox::getBoolean \
+
+ set editable [::combobox::GetBoolean \
$options(-editable)]
if {$editable} {
- $widgets(entry) configure -state normal -takefocus 1
+ $widgets(entry) configure -state normal
+ $widgets(entry) configure -takefocus 1
}
- $widgets(entry) configure -fg $::combobox::enabledfg
- } else {
+
+ # 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 -takefocus 0\
- -fg $::combobox::disabledfg
+ $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
}
- -textvariable {
- # destroy our trace on the old value, if any
- if {[string length $oldValue] > 0} {
- trace vdelete $oldValue w \
- [list ::combobox::vTrace $widgets(this)]
- }
- # set up a trace on the new value, if any. Also, set
- # the value of the widget to the current value of
- # the variable
+ -takefocus {
+ $widgets(entry) configure -takefocus $newValue
+ set options($option) $newValue
+ }
- set variable ::$newValue
- if {[string length $newValue] > 0} {
- if {[info exists $variable]} {
- ::combobox::setValue $widgets(this) [set $variable]
- }
- trace variable $variable w \
- [list ::combobox::vTrace $widgets(this)]
- }
+ -textvariable {
+ $widgets(entry) configure -textvariable $newValue
+ set options($option) $newValue
}
-value {
- ::combobox::setValue $widgets(this) $newValue
+ ::combobox::SetValue $widgets(this) $newValue
+ set options($option) $newValue
}
-width {
$widgets(entry) configure -width $newValue
$widgets(listbox) configure -width $newValue
+ set options($option) $newValue
}
- default {
- error "unknown option \"$option\""
+ -xscrollcommand {
+ $widgets(entry) configure -xscrollcommand $newValue
+ set options($option) $newValue
}
- }
+ }
+
+ if {$updateVisual} {UpdateVisualAttributes $w}
}
}
-# this proc is called whenever the user changes the value of
-# the -textvariable associated with a widget
-proc ::combobox::vTrace {w args} {
- upvar ::combobox::${w}::widgets widgets
- upvar ::combobox::${w}::options options
- upvar ::combobox::${w}::ignoreTrace ignoreTrace
+# ::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} {
- if {[info exists ignoreTrace]} return
- ::combobox::setValue $widgets(this) [set ::$options(-textvariable)]
+ 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
+ }
}
-# sets the value of the combobox and calls the -command, if defined
-proc ::combobox::setValue {w newValue {call 1}} {
+# ::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
- set editable [::combobox::getBoolean $options(-editable)]
-
- # update the widget, no matter what. This might cause a few
- # false triggers on a trace of the associated textvariable,
- # but that's a chance we'll have to take.
- $widgets(entry) configure -state normal
- $widgets(entry) delete 0 end
- $widgets(entry) insert 0 $newValue
- if {!$editable || $options(-state) != "normal"} {
- $widgets(entry) configure -state disabled
+ 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 the associated textvariable
- if {[string length $options(-textvariable)] > 0} {
- set ignoreTrace 1 ;# so we don't get in a recursive loop
- uplevel \#0 [list set $options(-textvariable) $newValue]
- unset ignoreTrace
+ # 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
}
- # Call the -command, if it exists.
- # We could optionally check to see if oldValue == newValue
- # first, but sometimes we want to execute the command even
- # if the value didn't change...
- # CYGNUS LOCAL
- # Call it after idle, so the menu gets unposted BEFORE
- # the command gets run... Make sure to clean up the afters
- # so you don't try to access a dead widget...
-
- if {$call && [string length $options(-command)] > 0} {
- if {[info exists widgets(after)]} {
- after cancel $widgets(after)
- }
- set widgets(after) [after idle $options(-command) \
- [list $widgets(this) $newValue]\;\
- unset ::combobox::${w}::widgets(after)]
+ 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
}
- set oldValue $newValue
}
-# returns the value of a (presumably) boolean string (ie: it should
-# do the right thing if the string is "yes", "no", "true", 1, etc
-proc ::combobox::getBoolean {value {errorValue 1}} {
+
+# ::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 {
}
}
-# computes the combobox widget name based on the name of one of
-# it's children widgets.. Not presently used, but might come in
-# handy...
-proc ::combobox::widgetName {w} {
- while {$w != "."} {
- if {[winfo class $w] == "Combobox"} {
- return $w
+# ::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)
+ }
+ }
}
- set w [winfo parent $w]
+
+ 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"
}
- error "internal error: $w is not a child of a combobox"
}
+
+# 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
+
OSDN Git Service
