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