* Re: tcl combobox widget
2003-05-20 0:12 tcl combobox widget John Williams
@ 2003-05-20 0:19 ` Bryan Oakley
2003-05-20 0:31 ` John Williams
0 siblings, 1 reply; 4+ messages in thread
From: Bryan Oakley @ 2003-05-20 0:19 UTC (permalink / raw)
To: jwilliams; +Cc: insight
[-- Attachment #1: Type: text/plain, Size: 542 bytes --]
On Monday, May 19, 2003, at 07:12 PM, John Williams wrote:
> Hi Bryan (cc: Insight mailing list),
>
> I just sent an email to your old address, not sure if you still get
> it, but I've found a stange bug with your combobox widget when running
> on my RH Linux 8.0 box.
This is a known bug, and I've just been too lazy to update a fix. Tcl's
behavior changed subtly in the 8.4 timeframe, and this bug is a result.
Try the attached version of the combobox and see if the problem goes
away.
--
Bryan Oakley
bryan at bitmover dot com
[-- Attachment #2: combobox.tcl --]
[-- Type: application/octet-stream, Size: 63040 bytes --]
# Copyright (c) 1998-2002, Bryan Oakley
# All Rights Reservered
#
# Bryan Oakley
# oakley@bardo.clearlight.com
#
# combobox v2.2.1 September 22, 2002
#
# 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
#
# 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.2.1
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} \
-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 \
]
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 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(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
# 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 \
-command "$widgets(listbox) yview" \
-highlightthickness 0
$widgets(button) configure \
-highlightthickness 0 \
-borderwidth 1 \
-relief raised \
-width [expr {[winfo reqwidth $widgets(vsb)] - 2}]
$widgets(entry) configure \
-borderwidth 0 \
-relief flat \
-highlightthickness 0
$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
# 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} {
# 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 ""
}
# ::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(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 ""
}
# ::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 out 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]}
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) 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).
#
# 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
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
# 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 {
-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
}
-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} {
$widgets(button) configure -image $newValue
} else {
$widgets(button) configure -image ::combobox::bimage
}
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} {
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
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
[-- Attachment #3: Type: text/plain, Size: 1 bytes --]
^ permalink raw reply [flat|nested] 4+ messages in thread