combobox.tcl

This Source-Navigator, an IDE for C/C++/Fortran/Java/Tcl/PHP/Python and a host of other languages.

# Copyright (c) 1998, Bryan Oakley
# All Rights Reservered
#
# Bryan Oakley
# [e-mail]
#
# combobox v1.05 August 17, 1998
# a dropdown combobox widget
#
# 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
#
#
# 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:
#
# Martin M. Hunt ([e-mail])

package require Tk 8.0
package provide combobox 1.05

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
    }

    # 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
        }; 
    }
}

# 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
proc ::combobox::combobox {w args} {

    # build it...
    eval build $w $args

    # set some bindings...
    setBindings $w

    # and we are done!
    return $w
}

# builds the combobox...
proc ::combobox::build {w args } {
    global tcl_platform
    if {[winfo exists $w]} {
	error "window name \"$w\" already exists"
    }

    # create the namespace...
    namespace eval ::combobox::$w {

	variable widgets
	variable options
	variable oldValue
	variable ignoreTrace
	variable grablist
	variable grabstatus
	variable this

	array set widgets {}
	array set options {}

	set oldValue {}
	set ignoreTrace 0
    }

    # import the widgets and options arrays into this proc
    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...

    # see... I'm pretending to be a Java programmer here...
    set this $w
    namespace eval ::combobox::$w "set this $this"

    # 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] 

    # 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] 
    }

    # 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(popup)   [toplevel $this.top]
    set widgets(listbox) [listbox $this.top.list]
    set widgets(vsb)     [scrollbar $this.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.
    $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

    $widgets(entry) configure \
	    -borderwidth 0 \
	    -relief flat \
	    -highlightthickness 0 

    $widgets(popup) configure \
	    -borderwidth 1 \
	    -relief sunken
    $widgets(listbox) configure \
	    -selectmode browse \
	    -background [$widgets(entry) cget -bg] \
	    -yscrollcommand "$widgets(vsb) set" \
	    -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)
    
    # this moves the original frame widget proc into our
    # namespace and gives it a handy name
    rename ::$this $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)
    }
}

# here's where we do most of the binding foo. I think there's probably
# a few bindings I ought to add that I just haven't thought about...
proc ::combobox::setBindings {w} {
    namespace eval ::combobox::$w {
	variable widgets
	variable options

	# make sure we clean up after ourselves...
	bind $widgets(this) <Destroy> [list ::combobox::destroyHandler $this]

	# this closes the listbox if we get hidden
	bind $widgets(this) <Unmap> "$widgets(this) close"

	# this helps (but doesn't fully solve) focus issues. 
	bind $widgets(this) <FocusIn> [list focus $widgets(entry)]

	# this makes our "button" (which is actually a label) 
	# do the right thing
	bind $widgets(button) <ButtonPress-1> [list $widgets(this) toggle]

	# this lets the autoscan of the listbox work, even if they
	# move the cursor over the entry widget. 
	bind $widgets(entry) <B1-Enter> "break"
	bind $widgets(entry) <FocusIn> \
		[list ::combobox::entryFocus $widgets(this) "<FocusIn>"]
	bind $widgets(entry) <FocusOut> \
		[list ::combobox::entryFocus $widgets(this) "<FocusOut>"]

	# this will (hopefully) close (and lose the grab on) the
	# listbox if the user clicks anywhere outside of it. Note
	# that on Windows, you can click on some other app and 
	# the listbox will still be there, because tcl won't see
	# that button click
	bind $widgets(this) <Any-ButtonPress> [list $widgets(this) close]
	bind $widgets(this) <Any-ButtonRelease> [list $widgets(this) close]

	bind $widgets(listbox) <ButtonRelease-1> \
	"::combobox::select $widgets(this) \[$widgets(listbox) nearest %y\]; break"

	bind $widgets(listbox) <Any-Motion> {
	    %W selection clear 0 end
	    %W activate @%x,%y
	    %W selection anchor @%x,%y
	    %W selection set @%x,%y @%x,%y
	    # need to do a yview if the cursor goes off the top
	    # or bottom of the window... (or do we?)
	}

	# these events need to be passed from the entry
	# widget to the listbox, or need some sort of special
	# handling....
	foreach event [list <Up> <Down> <Tab> <Return> <Escape> \
		<Next> <Prior> <Double-1> <1> <Any-KeyPress> \
		<FocusIn> <FocusOut>] {
	    bind $widgets(entry) $event \
		    "::combobox::handleEvent $widgets(this) $event"
	}

    }
}

# 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} {
    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 {
	"<Any-KeyPress>" {
	    set editable [::combobox::getBoolean $options(-editable)]
	    # if the widget is editable, clear the selection. 
	    # this makes it more obvious what will happen if the 
	    # user presses <Return> (and helps our code know what
	    # to do if the user presses return)
	    if {$editable} {
		$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>" {
	    $widgets(entry) delete 0 end
	    $widgets(entry) insert 0 $oldValue
	}

	"<1>" {
	    set editable [::combobox::getBoolean $options(-editable)]
	    if {!$editable} {
		if {[winfo ismapped $widgets(popup)]} {
		    $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(popup)]} {
		::combobox::find $widgets(this)
		return -code break;
	    }
	}
	"<Escape>" {
	    $widgets(entry) delete 0 end
	    $widgets(entry) insert 0 $oldValue
	    if {[winfo ismapped $widgets(popup)]} {
		$widgets(this) close
		return -code break;
	    }
	}

	"<Return>" {