combobox.tcl

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

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

	    if {[winfo ismapped $widgets(popup)]} {
		::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(popup)]} {
		if {$options(-state) != "disabled"} {
		    $widgets(this) open
		    return -code break;
		}
	    } else {
		tkListboxUpDown $widgets(listbox) 1
		return -code break;
	    }
	}
	"<Up>" {
	    if {![winfo ismapped $widgets(popup)]} {
		if {$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)
        }
    }

#    catch {rename ::combobox::${w}::$w {}}
    # kill the namespace
    catch {namespace delete ::combobox::$w}
}

# finds something in the listbox that matches the pattern in the
# entry widget
#
# 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}} {
    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
    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} {
	$widgets(listbox) selection clear 0 end
	$widgets(listbox) see $index
    } else {
	$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
    }
}

# selects an item from the list and sets the value of the combobox
# to that value
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
    }

    $widgets(this) close
}

# 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} {
    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
    }
    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}]
    }
    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]
    }
    set location "+[winfo rootx $widgets(this)]+$y"
    set geometry "=${size}${location}"
    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} {
    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

	# replace specific instances of the subwidget command
	# with out megawidget command
	switch $subwidget,$subcommand {
	    listbox,index  {regsub "index"  $result "list index"  result}
	    listbox,insert {regsub "insert" $result "list insert" result}
	    listbox,delete {regsub "delete" $result "list delete" result}
	    listbox,get    {regsub "get"    $result "list get"    result}
	    listbox,size   {regsub "size"   $result "list size"   result}
	    listbox,curselection   {regsub "curselection"   $result "list curselection"   result}
	}
	error $result

    } else {
	return $result
    }
}


# this is the widget proc that gets called when you do something like
# ".checkbox configure ..."
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

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

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

        entryset {
          # update the entry field without invoking the command
	  ::combobox::setValue $widgets(this) [lindex $args 0] 0
	}

	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(popup)]} {
		$widgets(this) close
	    } else {
		$widgets(this) open
	    }
	}