mclistbox.wgt

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

	    # is set to an empty string.
	    foreach id $misc(columns) {
		eval {$widgets(listbox$id)} delete $index1 $index2
	    }
	    eval {$widgets(hiddenListbox)} delete $index1 $index2

	    InvalidateScrollbars $w

	    set result ""
	}

	get {
	    if {[llength $args] < 1 || [llength $args] > 2} {
		return -code error "wrong \# of args: should be $w get first ?last?"
	    }
	    set index1 [::mclistbox::MassageIndex $w [lindex $args 0]]
	    if {[llength $args] == 2} {
		set index2 [::mclistbox::MassageIndex $w [lindex $args 1]]
	    } else {
		set index2 ""
	    }

	    set result [eval ::mclistbox::WidgetProc-get {$w} $index1 $index2]

	}

	index {

	    if {[llength $args] != 1} {
		return -code error "wrong \# of args: should be $w index index"
	    }

	    set index [::mclistbox::MassageIndex $w [lindex $args 0]]
	    set id [lindex $misc(columns) 0]

	    set result [$widgets(listbox$id) index $index]
	}

	insert {
	    if {[llength $args] < 1} {
		return -code error "wrong \# of args: should be $w insert ?element \
		      element...?"
	    }

	    # it's possible that the selection will change because
	    # of something we do. So, grab the current selection before
	    # we do anything. Just before returning we'll see if the
	    # selection has changed. If so, we'll call our selectcommand
	    if {$options(-selectcommand) != ""} {
		set col0 [lindex $misc(columns) 0]
		set priorSelection [$widgets(listbox$col0) curselection]
	    }

	    set index [::mclistbox::MassageIndex $w [lindex $args 0]]

	    ::mclistbox::Insert $w $index [lrange $args 1 end]

	    InvalidateScrollbars $w
	    set result ""
	}

	nearest {
	    if {[llength $args] != 1} {
		return -code error "wrong \# of args: should be $w nearest y"
	    }

	    # translate the y coordinate into listbox space
	    set id [lindex $misc(columns) 0]
	    set y [lindex $args 0]
	    incr y -[winfo y $widgets(listbox$id)]
	    incr y -[winfo y $widgets(frame$id)]

	    set col0 [lindex $misc(columns) 0]

	    set result [$widgets(listbox$col0) nearest $y]
	}

	scan {
	    foreach {subcommand x y} $args {}
	    switch $subcommand {
		mark {
		    # we have to treat scrolling in x and y differently;
		    # scrolling in the y direction affects listboxes and
		    # scrolling in the x direction affects the text widget.
		    # to facilitate that, we need to keep a local copy
		    # of the scan mark.
		    set misc(scanmarkx) $x
		    set misc(scanmarky) $y
		    
		    # set the scan mark for each column
		    foreach id $misc(columns) {
			$widgets(listbox$id) scan mark $x $y
		    }

		    # we can't use the x coordinate given us, since it 
		    # is relative to whatever column we are over. So,
		    # we'll just usr the results of [winfo pointerx].
		    $widgets(text) scan mark [winfo pointerx $w]  $y
		}
		dragto {
		    # we want the columns to only scan in the y direction,
		    # so we'll force the x componant to remain constant
		    foreach id $misc(columns) {
			$widgets(listbox$id) scan dragto $misc(scanmarkx) $y
		    }

		    # since the scan mark of the text widget was based
		    # on the pointer location, so must be the x
		    # coordinate to the dragto command. And since we
		    # want the text widget to only scan in the x
		    # direction, the y componant will remain constant
		    $widgets(text) scan dragto \
			    [winfo pointerx $w] $misc(scanmarky)

		    # make sure the scrollbars reflect the changes.
		    InvalidateScrollbars $w
		}

		set result ""
	    }
	}

	see {
	    if {[llength $args] != 1} {
		return -code error "wrong \# of args: should be $w see index"
	    }
	    set index [::mclistbox::MassageIndex $w [lindex $args 0]]

	    foreach id $misc(columns) {
		$widgets(listbox$id) see $index
	    }
	    InvalidateScrollbars $w
	    set result {}
	}

	selection {
	    # it's possible that the selection will change because
	    # of something we do. So, grab the current selection before
	    # we do anything. Just before returning we'll see if the
	    # selection has changed. If so, we'll call our selectcommand
	    if {$options(-selectcommand) != ""} {
		set col0 [lindex $misc(columns) 0]
		set priorSelection [$widgets(listbox$col0) curselection]
	    }

	    set subcommand [lindex $args 0]
	    set args [lrange $args 1 end]

	    set prefix "wrong \# of args: should be $w"
	    switch $subcommand {
		includes {
		    if {[llength $args] != 1} {
			return -code error "$prefix selection $subcommand index"
		    }
		    set index [::mclistbox::MassageIndex $w [lindex $args 0]]
		    set id [lindex $misc(columns) 0]
		    set result [$widgets(listbox$id) selection includes $index]
		}

		set {
		    switch [llength $args] {
			1 {
			    set index1 [::mclistbox::MassageIndex $w \
				    [lindex $args 0]]
			    set index2 ""
			}
			2 {
			    set index1 [::mclistbox::MassageIndex $w \
				    [lindex $args 0]]
			    set index2 [::mclistbox::MassageIndex $w \
				    [lindex $args 1]]
			}
			default {
			    return -code error "$prefix selection clear first ?last?"
			}
		    }

		    if {$options(-exportselection)} {
			SelectionHandler $w own
		    }
		    if {$index1 != ""} {
			foreach id $misc(columns) {
			    eval {$widgets(listbox$id)} selection set \
				    $index1 $index2
			}
		    }

		    set result ""
		}

		anchor {
		    if {[llength $args] != 1} {
			return -code error "$prefix selection $subcommand index"
		    }
		    set index [::mclistbox::MassageIndex $w [lindex $args 0]]

		    if {$options(-exportselection)} {
			SelectionHandler $w own
		    }
		    foreach id $misc(columns) {
			$widgets(listbox$id) selection anchor $index
		    }
		    set result ""
		}

		clear {
		    switch [llength $args] {
			1 {
			    set index1 [::mclistbox::MassageIndex $w \
				    [lindex $args 0]]
			    set index2 ""
			}
			2 {
			    set index1 [::mclistbox::MassageIndex $w \
				    [lindex $args 0]]
			    set index2 [::mclistbox::MassageIndex $w \
				    [lindex $args 1]]
			}
			default {
			    return -code error "$prefix selection clear first ?last?"
			}
		    }

		    if {$options(-exportselection)} {
			SelectionHandler $w own
		    }
		    foreach id $misc(columns) {
			eval {$widgets(listbox$id)} selection clear \
				$index1 $index2
		    }
		    set result ""
		}
	    }
	}

	size {
	    set id [lindex $misc(columns) 0]
	    set result [$widgets(listbox$id) size]
	}
    }

    # if the user has a selectcommand defined and the selection changed,
    # run the selectcommand
    if {[info exists priorSelection] && $options(-selectcommand) != ""} {
	set column [lindex $misc(columns) 0]
	set currentSelection [$widgets(listbox$column) curselection]
	if {[string compare $priorSelection $currentSelection] != 0} {
	    # this logic keeps us from getting into some sort of
	    # infinite loop of the selectcommand changes the selection
	    # (not particularly well tested, but it seems like the
	    # right thing to do...)
	    if {![info exists misc(skipRecursiveCall)]} {
		set misc(skipRecursiveCall) 1
		uplevel \#0 $options(-selectcommand) $currentSelection
		catch {unset misc(skipRecursiveCall)}
	    }
	}
    }

    return $result
}

# ::mclistbox::WidgetProc-get --
#
#    Implements the "get" widget command
#
# Arguments:
#
#    w      widget path
#    args   additional arguments to the get command

proc ::mclistbox::WidgetProc-get {w args} {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    set returnType "list"
    # the listbox "get" command returns different things
    # depending on whether it has one or two args. Internally
    # we *always* want a valid list, so we'll force a second
    # arg which in turn forces the listbox to return a list,
    # even if its a list of one element
    if {[llength $args] == 1} {
	lappend args [lindex $args 0]
	set returnType "listOfLists"
    }

    # get all the data from each column
    foreach id $misc(columns) {
	set data($id) [eval {$widgets(listbox$id)} get $args]
    }

    # now join the data together one row at a time. Ugh.
    set result {}
    set rows [llength $data($id)]
    for {set i 0} {$i < $rows} {incr i} {
	set this {}
	foreach column $misc(columns) {
	    lappend this [lindex $data($column) $i]
	}
	lappend result $this
    }
    
    # now to unroll the list if necessary. If the user gave
    # us only one indicie we want to return a single list
    # of values. If they gave use two indicies we want to return
    # a list of lists.
    if {[string compare $returnType "list"] == 0} {
	return $result
    } else {
	return [lindex $result 0]
    }
}

# ::mclistbox::CheckColumnID --
#
#    returns the index of the id within our list of columns, or 
#    reports an error if the id is invalid
#
# Arguments:
#
#    w    widget pathname
#    id   a column id
#
# Results:
#
#   Will compute and return the index of the column within the
#   list of columns (which happens to be it's -position, as it
#   turns out) or returns an error if the named column doesn't
#   exist.

proc ::mclistbox::CheckColumnID {w id} {
    upvar ::mclistbox::${w}::misc    misc

    set id [::mclistbox::Canonize $w column $id]
    set index [lsearch -exact $misc(columns) $id]
    return $index
}

# ::mclistbox::LabelEvent --
#
#    Handle user events on the column labels for the Mclistbox
#    class. 
#
# Arguments:
#
#    w        widget pathname
#    id       a column identifier
#    code     tcl code to be evaluated.
#
# Results:
#
#    Executes the code associate with an event, but only if the
#    event wouldn't otherwise potentially trigger a resize event.
#
#    We use the cursor of the label to let us know whether the
#    code should be executed. If it is set to the cursor of the
#    mclistbox widget, the code will be executed. It is assumed
#    that if it is not the same cursor, it is the resize cursor
#    which should only be set if the cursor is very near a border
#    of a label and the column is resizable.

proc ::mclistbox::LabelEvent {w id code} {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options

    # only fire the binding if the cursor is our default cursor
    # (ie: if we aren't in a "resize zone")
    set cursor [$widgets(label$id) cget -cursor]
    if {[string compare $cursor $options(-cursor)] == 0} {
	uplevel \#0 $code
    }
}

# ::mclistbox::HumanizeList --
#
#    Returns a human-readable form of a list by separating items
#    by columns, but separating the last two elements with "or"
#    (eg: foo, bar or baz)
#
# Arguments:
#
#    list    a valid tcl list
#
# Results:
#
#    A string which as all of the elements joined with ", " or 
#    the word " or "

proc ::mclistbox::HumanizeList {list} {

    if {[llength $list] == 1} {
	return [lindex $list 0]
    } else {
	set list [lsort $list]
	set secondToLast [expr {[llength $list] -2}]
	set most [lrange $list 0 $secondToLast]
	set last [lindex $list end]

	return "[join $most {, }] or $last"
    }
}

# ::mclistbox::Canonize --
#
#    takes a (possibly abbreviated) option or command name and either 
#    returns the canonical name or an error
#
# Arguments:
#
#    w        widget pathname
#    object   type of object to canonize; must be one of "command",
#             "option", "column" or "column option".
#    opt      the option (or command) to be canonized
#
#