combobox.tcl

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

	open {
	    # if we are disabled, we won't allow this to happen
	    if {$options(-state) == "disabled"} {
		return 0
	    }

	    # 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(popup) $geometry
	    update idletasks

	    # if we are already open, there's nothing else to do
	    if {[winfo ismapped $widgets(popup)]} {
		return 0
	    }

	    # 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)]
	    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]
	    }
	    grab -global $widgets(this)

	    # fake the listbox into thinking it has focus
	    event generate $widgets(listbox) <B1-Enter>

	    return 1
	}

	close {
	    # if we are already closed, don't do anything...
	    if {![winfo ismapped $widgets(popup)]} {
		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
		}
	    }
	    set grablist {}
	    set grabstatus {}
	    $widgets(button) configure -relief raised
	    wm withdraw $widgets(popup) 

	    # 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)
	    tkCancelRepeat

	    return 1
	}

	cget {
	    # tries to mimic the standard "cget" command
	    if {[llength $args] != 1} {
		error "wrong # args: should be \"$widgets(this) 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

	    } elseif {[llength $args] == 1} {
		# they are requesting configure information...
		set option [lindex $args 0]
		return [::combobox::configure $widgets(this) get $option]
	    } else {
		array set tmpopt $args
		foreach opt [array names tmpopt] {
		    ::combobox::configure $widgets(this) set $opt $tmpopt($opt)
		}
	    }
	}
	default {
	    error "bad option \"$command\""
	}
    }
}

# handles all of the configure and cget foo
proc ::combobox::configure {w action {option ""} {newValue ""}} {
    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)
	}

    } else {

	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
	    }

	    -borderwidth {
		$widgets(frame) configure -borderwidth $newValue
	    }

	    -command {
		# nothing else to do...
	    }

	    -cursor {
		$widgets(frame) configure -cursor $newValue
		$widgets(entry) configure -cursor $newValue
		$widgets(listbox) configure -cursor $newValue
	    }

	    -editable {
		if {$newValue} {
		    # it's editable...
		    $widgets(entry) configure -state normal
		} else {
		    $widgets(entry) configure -state disabled
		}
	    }

	    -font {
		$widgets(entry) configure -font $newValue
		$widgets(listbox) configure -font $newValue
	    }

	    -foreground {
		$widgets(entry)   configure -foreground $newValue
		$widgets(button)  configure -foreground $newValue
		$widgets(listbox) configure -foreground $newValue
	    }

	    -height {
		$widgets(listbox) configure -height $newValue
	    }

	    -highlightbackground {
		$widgets(frame) configure -highlightbackground $newValue
	    }

	    -highlightthickness {
		$widgets(frame) configure -highlightthickness $newValue
	    }
	    
	    -image {
		if {[string length $newValue] > 0} {
		    $widgets(button) configure -image $newValue
		} else {
		    $widgets(button) configure -image ::combobox::bimage
		}
	    }

	    -maxheight {
		# computeGeometry may dork with the actual height
		# of the listbox, so let's undork it
		$widgets(listbox) configure -height $options(-height)
	    }

	    -relief {
		$widgets(frame) configure -relief $newValue
	    }

	    -selectbackground {
		$widgets(entry) configure -selectbackground $newValue
		$widgets(listbox) configure -selectbackground $newValue
	    }

	    -selectborderwidth {
		$widgets(entry) configure -selectborderwidth $newValue
		$widgets(listbox) configure -selectborderwidth $newValue
	    }

	    -selectforeground {
		$widgets(entry) configure -selectforeground $newValue
		$widgets(listbox) configure -selectforeground $newValue
	    }

	    -state {
		if {$newValue == "normal"} {
		    # it's enabled
		    set editable [::combobox::getBoolean \
			    $options(-editable)]
		    if {$editable} {
			$widgets(entry) configure -state normal -takefocus 1
		    }
		    $widgets(entry) configure -fg $::combobox::enabledfg
		} else {
		    # it's disabled
		    $widgets(entry) configure -state disabled -takefocus 0\
		      -fg $::combobox::disabledfg
		}
	    }

	    -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

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

	    -value {
		::combobox::setValue $widgets(this) $newValue
	    }

	    -width {
		$widgets(entry) configure -width $newValue
		$widgets(listbox) configure -width $newValue
	    }

	    default {
		error "unknown option \"$option\""
	    }
	}
    }
}

# 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

    if {[info exists ignoreTrace]} return
    ::combobox::setValue $widgets(this) [set ::$options(-textvariable)]
}

# sets the value of the combobox and calls the -command, if defined
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
    }

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

    # 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)]
    }
    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}} {
    if {[catch {expr {([string trim $value])?1:0}} res]} {
	return $errorValue
    } else {
	return $res
    }
}

# 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
	}
	set w [winfo parent $w]
    }
    error "internal error: $w is not a child of a combobox"
}