mclistbox.wgt

一个跨平台的TCL/TK可视开发环境类似VC. TCL/TK是一个跨平台的脚本语言.

		    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] != "Mclistbox"} {
		    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] != "Mclistbox"} {
		    set win [winfo parent $win]
		    if {$win == "."} break;
		}
		lappend result $win
	    }
	}
    }
    return $result
}

# ::mclistbox::SetBindings --
#
#    Sets up the default bindings for the named widget
#
# Arguments:
#
#    w   the widget pathname for which the bindings should be assigned
#
# Results:
#
#    The named widget will inheirit all of the default Mclistbox
#    bindings.

proc ::mclistbox::SetBindings {w} {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    # we must do this so that the columns fill the text widget in
    # the y direction
    bind $widgets(text) <Configure> \
	    [list ::mclistbox::AdjustColumns $w %h]

}

# ::mclistbox::SetClassBindings --
#
#    Sets up the default bindings for the widget class
#
# Arguments:
#
#    none
#

proc ::mclistbox::SetClassBindings {} {
    # this allows us to clean up some things when we go away
    bind Mclistbox <Destroy> [list ::mclistbox::DestroyHandler %W]

    # steal all of the standard listbox bindings. Note that if a user
    # clicks in a column, %W will return that column. This is bad,
    # so we have to make a substitution in all of the bindings to
    # compute the real widget name (ie: the name of the topmost 
    # frame)
    foreach event [bind Listbox] {
	set binding [bind Listbox $event]
	regsub -all {%W} $binding {[::mclistbox::convert %W -W]} binding
	regsub -all {%x} $binding {[::mclistbox::convert %W -x %x]} binding
	regsub -all {%y} $binding {[::mclistbox::convert %W -y %y]} binding
	bind Mclistbox $event $binding
    }

    # these define bindings for the column labels for resizing. Note
    # that we need both the name of this widget (calculated by $this)
    # as well as the specific widget that the event occured over.
    # Also note that $this is a constant string that gets evaluated
    # when the binding fires.
    # What a pain.
    set this {[::mclistbox::convert %W -W]}
    bind MclistboxMouseBindings <ButtonPress-1> \
	    "::mclistbox::ResizeEvent $this buttonpress %W %x %X %Y"
    bind MclistboxMouseBindings <ButtonRelease-1> \
	    "::mclistbox::ResizeEvent $this buttonrelease %W %x %X %Y"
    bind MclistboxMouseBindings <Enter> \
	    "::mclistbox::ResizeEvent $this motion %W %x %X %Y"
    bind MclistboxMouseBindings <Motion> \
	    "::mclistbox::ResizeEvent $this motion %W %x %X %Y"
    bind MclistboxMouseBindings <B1-Motion> \
	    "::mclistbox::ResizeEvent $this drag %W %x %X %Y"
}

# ::mclistbox::NewColumn --
#
#    Adds a new column to the mclistbox widget
#
# Arguments:
#
#    w     the widget pathname
#    id    the id for the new column
#
# Results:
#
#    Creates a set of widgets which defines the column. Adds 
#    appropriate entries to the global array widgets for the
#    new column. 
#
#    Note that this column is not added to the listbox by 
#    this proc.
#
# Returns:
#
#    A list of three elements: the path to the column frame, 
#    the path to the column listbox, and the path to the column
#    label, in that order.

proc ::mclistbox::NewColumn {w id} {
    upvar ::mclistbox::${w}::widgets   widgets
    upvar ::mclistbox::${w}::options   options
    upvar ::mclistbox::${w}::misc      misc
    upvar ::mclistbox::${w}::columnID  columnID

    # the columns are all children of the text widget we created... 
    set frame     \
	    [frame $w.frame$id \
	    -takefocus 0 \
	    -highlightthickness 0 \
	    -class MclistboxColumn \
	    -background $options(-background) \
	    ]

    set listbox   \
	    [listbox $frame.listbox \
	    -takefocus 0 \
	    -bd 0 \
	    -setgrid $options(-setgrid) \
	    -exportselection false \
	    -selectmode $options(-selectmode) \
	    -highlightthickness 0 \
	    ]

    set label     \
	    [label $frame.label \
	    -takefocus 0 \
	    -relief raised \
	    -bd 1 \
	    -highlightthickness 0 \
	    ]

    # define mappings from widgets to columns
    set columnID($label) $id
    set columnID($frame) $id
    set columnID($listbox) $id

    # we're going to associate a new bindtag for the label to
    # handle our resize bindings. Why? We want the bindings to
    # be specific to this widget but we don't want to use the
    # widget name. If we use the widget name then the bindings
    # could get mixed up with user-supplied bindigs (via the 
    # "label bind" command). 
    set tag MclistboxLabel
    bindtags $label  [list MclistboxMouseBindings $label]

    # reconfigure the label based on global options
    foreach option [list bd image height relief font anchor \
	    background foreground borderwidth] {
	if {[info exists options(-label$option)] \
		&& $options(-label$option) != ""} {
	    $label configure -$option $options(-label$option)
	}
    }

    # reconfigure the column based on global options
    foreach option [list borderwidth relief] {
	if {[info exists options(-column$option)] \
		&& $options(-column$option) != ""} {
	    $frame configure -$option $options(-column$option)
	}
    }

    # geometry propagation must be off so we can control the size
    # of the listbox by setting the size of the containing frame
    pack propagate $frame off

    pack $label   -side top -fill x -expand n
    pack $listbox -side top -fill both -expand y -pady 2

    # any events that happen in the listbox gets handled by the class
    # bindings. This has the unfortunate side effect 
    bindtags $listbox [list $w Mclistbox all]

    # return a list of the widgets we created.
    return [list $frame $listbox $label]
}

# ::mclistbox::Column-add --
#
#    Implements the "column add" widget command
#
# Arguments:
#
#    w      the widget pathname
#    args   additional option/value pairs which define the column
#
# Results:
#
#    A column gets created and added to the listbox

proc ::mclistbox::Column-add {w args} {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    variable widgetOptions

    set id "column-[llength $misc(columns)]" ;# a suitable default

    # if the first argument doesn't have a "-" as the first
    # character, it is an id to associate with this column
    if {![string match {-*} [lindex $args 0]]} {
	# the first arg must be an id.
	set id [lindex $args 0]
	set args [lrange $args 1 end]
	if {[lsearch -exact $misc(columns) $id] != -1} {
	    return -code error "column \"$id\" already exists"
	}
    }

    # define some reasonable defaults, then add any specific
    # values supplied by the user
    set opts(-bitmap)     {}
    set opts(-image)      {}
    set opts(-labelrelief) raised
    set opts(-visible)    1
    set opts(-resizable)  1
    set opts(-position)   "end"
    set opts(-width)      20
    set opts(-background) $options(-background)
    set opts(-foreground) $options(-foreground)
    set opts(-font)       $options(-font)
    set opts(-label)      $id

    if {[expr {[llength $args]%2}] == 1} {
	# hmmm. An odd number of elements in args
	# if the last item is a valid option we'll give a different
	# error than if its not
	set option [::mclistbox::Canonize $w "column option" [lindex $args end]]
	return -code error "value for \"[lindex $args end]\" missing"
    }
    array set opts $args

    # figure out if we have any data in the listbox yet; we'll need
    # this information in a minute...
    if {[llength $misc(columns)] > 0} {
	set col0 [lindex $misc(columns) 0]
	set existingRows [$widgets(listbox$col0) size]
    } else {
	set existingRows 0
    }

    # create the widget and assign the associated paths to our array
    set widgetlist [NewColumn $w $id]

    set widgets(frame$id)   [lindex $widgetlist 0]
    set widgets(listbox$id) [lindex $widgetlist 1]
    set widgets(label$id)   [lindex $widgetlist 2]
    
    # add this column to the list of known columns
    lappend misc(columns) $id

    # configure the options. As a side effect, it will be inserted
    # in the text widget
    eval ::mclistbox::Column-configure {$w} {$id} [array get opts]

    # now, if there is any data already in the listbox, we need to
    # add a corresponding number of blank items. At least, I *think*
    # that's the right thing to do.
    if {$existingRows > 0} {
	set blanks {}
	for {set i 0} {$i < $existingRows} {incr i} {
	    lappend blanks {}
	}
	eval {$widgets(listbox$id)} insert end $blanks
    }

    InvalidateScrollbars $w
    return $id
}

# ::mclistbox::Column-configure --
#
#    Implements the "column configure" widget command
#
# Arguments:
#
#    w     widget pathname
#    id    column identifier
#    args  list of option/value pairs

proc ::mclistbox::Column-configure {w id args} {
    variable widgetOptions
    variable columnOptions

    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    # bail if they gave us a bogus id
    set index [CheckColumnID $w $id]

    # define some shorthand
    set listbox $widgets(listbox$id)
    set frame   $widgets(frame$id)
    set label   $widgets(label$id)

    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 columnOptions]] {
	    if {[llength $columnOptions($opt)] == 1} {
		set alias $columnOptions($opt)
		set optName $columnOptions($alias)
		lappend results [list $opt $optName]
	    } else {
		set optName  [lindex $columnOptions($opt) 0]
		set optClass [lindex $columnOptions($opt) 1]
		set default [option get $frame $optName $optClass]
		lappend results [list $opt $optName $optClass \
			$default $options($id:$opt)]
	    }
	}

	return $results


    } elseif {[llength $args] == 1} {

	# the user must be querying something... I need to get this
	# to return a bona fide list like the "real" configure 
	# command, but it's not a priority at the moment. I still
	# have to work on the option database support foo.
	set option [::mclistbox::Canonize $w "column option" [lindex $args 0]]

	set value $options($id:$option)
	set optName  [lindex $columnOptions($option) 0]
	set optClass [lindex $columnOptions($option) 1]
	set default  [option get $frame $optName $optClass]
	set results  [list $option $optName $optClass $default $value]
	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
	return -code 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 [::mclistbox::Canonize $w "column option" $name]
	set opts($name) $value
    }

    # if we get to here, the user is wanting to set some options
    foreach option [array names opts] {
	set value $opts($option)
	set options($id:$option) $value

	switch -- $option {
	    -label {
		$label configure -text $value
	    }
	    
	    -image -
	    -bitmap {
		$label configure $option $value
	    }

	    -width {
		set font [$listbox cget -font]
		set factor [font measure $options(-font) "0"]
		set width [expr {$value * $factor}]

		$widgets(frame$id) configure -width $width
		set misc(min-$widgets(frame$id)) $width
		AdjustColumns $w
	    }
	    -font -
	    -foreground -
	    -background {
		if {[string length $value] == 0} {set value $options($option)}
		$listbox configure $option $value
	    }

	    -labelrelief {
		$widgets(label$id) configure -relief $value
	    }