From: hunt Date: Tue, 4 Feb 2003 07:33:38 +0000 (+0000) Subject: 2003-02-03 Martin M. Hunt X-Git-Url: http://git.osdn.net/view?a=commitdiff_plain;h=f8788198026e349971c39a53d46bdfb3338ffc44;p=pf3gnuchains%2Fpf3gnuchains3x.git 2003-02-03 Martin M. Hunt * library/combobox.tcl: Import combobox 2.2.1 * library/pkgIndex.tcl: Change combobox version to 2.2.1. --- diff --git a/libgui/ChangeLog b/libgui/ChangeLog index 3cdf00f1c1..a7f6e270de 100644 --- a/libgui/ChangeLog +++ b/libgui/ChangeLog @@ -1,3 +1,8 @@ +2003-02-03 Martin M. Hunt + + * library/combobox.tcl: Import combobox 2.2.1 + * library/pkgIndex.tcl: Change combobox version to 2.2.1. + 2003-01-21 Martin M. Hunt * src/tkTabletcl.h: Change all references of "tkPriv" diff --git a/libgui/library/combobox.tcl b/libgui/library/combobox.tcl index 0183712320..ab2e33b9ae 100644 --- a/libgui/library/combobox.tcl +++ b/libgui/library/combobox.tcl @@ -1,169 +1,492 @@ -# 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 [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 "$this close" + bind Combobox "$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 {::combobox::tkTabToWindow [::combobox::convert %W -W].entry} + + # this closes the listbox if we get hidden + bind Combobox {[::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) \ + "::combobox::tkTabToWindow \[tk_focusNext $widgets(entry)\]; break" + bind $widgets(entry) \ + "::combobox::tkTabToWindow \[tk_focusPrev $widgets(this)\]; break" + + # this makes our "button" (which is actually a label) + # do the right thing + bind $widgets(button) [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) "break" + + bind $widgets(listbox) \ + "::combobox::Select [list $widgets(this)] \ + \[$widgets(listbox) nearest %y\]; break" + + bind $widgets(vsb) {continue} + bind $widgets(vsb) {continue} + + bind $widgets(listbox) { + %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 \ + <1> \ + ] { + bind $widgets(entry) $event \ + [list ::combobox::HandleEvent $widgets(this) $event] + } + + # like the other events, 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) \ + [list ::combobox::HandleEvent $widgets(this) %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 @@ -173,9 +496,9 @@ proc ::combobox::build {w args } { # 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 @@ -184,128 +507,82 @@ proc ::combobox::build {w args } { # 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) [list ::combobox::destroyHandler $this] - - # this closes the listbox if we get hidden - bind $widgets(this) "$widgets(this) close" - - # this helps (but doesn't fully solve) focus issues. - bind $widgets(this) [list focus $widgets(entry)] - - # this makes our "button" (which is actually a label) - # do the right thing - bind $widgets(button) [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) "break" - bind $widgets(entry) \ - [list ::combobox::entryFocus $widgets(this) ""] - bind $widgets(entry) \ - [list ::combobox::entryFocus $widgets(this) ""] - - # 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) [list $widgets(this) close] - bind $widgets(this) [list $widgets(this) close] - - bind $widgets(listbox) \ - "::combobox::select $widgets(this) \[$widgets(listbox) nearest %y\]; break" - - bind $widgets(listbox) { - %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 \ - <1> \ - ] { - 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 @@ -315,13 +592,24 @@ proc ::combobox::handleEvent {w event} { # bindings from firing. Otherwise we'll let the event fall # on through. switch $event { + + "" { + 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 + } + } + "" { - 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 (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 @@ -334,14 +622,19 @@ proc ::combobox::handleEvent {w event} { } "" { - $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; @@ -360,44 +653,34 @@ proc ::combobox::handleEvent {w event} { return -code break; } } + "" { - 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] } } + "" { - $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; } } "" { - 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; } @@ -426,63 +709,86 @@ proc ::combobox::handleEvent {w event} { } "" { - 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; } } "" { - 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 @@ -508,6 +814,7 @@ proc ::combobox::find {w {exact 0}} { # 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] } @@ -532,10 +839,10 @@ proc ::combobox::find {w {exact 0}} { 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 @@ -567,9 +874,17 @@ proc ::combobox::find {w {exact 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 - } 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 @@ -579,27 +894,114 @@ proc ::combobox::find {w {exact 0}} { $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 @@ -617,44 +1019,128 @@ proc ::combobox::computeGeometry {w} { } 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 @@ -664,7 +1150,6 @@ proc ::combobox::doInternalWidgetCommand {w subwidget command args} { 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 @@ -674,17 +1159,39 @@ proc ::combobox::doInternalWidgetCommand {w subwidget command args} { } -# 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 @@ -695,51 +1202,71 @@ proc ::combobox::widgetProc {w command args} { # 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 { @@ -748,19 +1275,35 @@ proc ::combobox::widgetProc {w command args} { # 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). @@ -769,36 +1312,50 @@ proc ::combobox::widgetProc {w command args} { # 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) return 1 @@ -806,164 +1363,261 @@ proc ::combobox::widgetProc {w command args} { 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 { @@ -972,145 +1626,279 @@ proc ::combobox::configure {w action {option ""} {newValue ""}} { } 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 { @@ -1118,15 +1906,254 @@ proc ::combobox::getBoolean {value {errorValue 1}} { } } -# 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 {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 will convert the value ; typically will +# be the result of a %x substitution +# -y will convert the value ; typically 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 + diff --git a/libgui/library/pkgIndex.tcl b/libgui/library/pkgIndex.tcl index 9193a88448..82af226b87 100644 --- a/libgui/library/pkgIndex.tcl +++ b/libgui/library/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded combobox 1.05 [list source [file join $dir combobox.tcl]] +package ifneeded combobox 2.2.1 [list source [file join $dir combobox.tcl]] package ifneeded debug 1.0 [list source [file join $dir debug.tcl]]