# multibox.tcl - Multi-column listbox.
|
# multibox.tcl - Multi-column listbox.
|
# Copyright (C) 1997 Cygnus Solutions.
|
# Copyright (C) 1997 Cygnus Solutions.
|
# Written by Tom Tromey <tromey@cygnus.com>.
|
# Written by Tom Tromey <tromey@cygnus.com>.
|
|
|
# FIXME:
|
# FIXME:
|
# * Should support sashes so user can repartition widget sizes.
|
# * Should support sashes so user can repartition widget sizes.
|
# * Should support itemcget, itemconfigure.
|
# * Should support itemcget, itemconfigure.
|
|
|
itcl_class Multibox {
|
itcl_class Multibox {
|
# The selection mode.
|
# The selection mode.
|
public selectmode browse {
|
public selectmode browse {
|
_apply_all configure [list -selectmode $selectmode]
|
_apply_all configure [list -selectmode $selectmode]
|
}
|
}
|
|
|
# The height.
|
# The height.
|
public height 10 {
|
public height 10 {
|
_apply_all configure [list -height $height]
|
_apply_all configure [list -height $height]
|
}
|
}
|
|
|
# This is a list of all the listbox widgets we've created. Private
|
# This is a list of all the listbox widgets we've created. Private
|
# variable.
|
# variable.
|
protected _listboxen {}
|
protected _listboxen {}
|
|
|
# Tricky: take the class bindings for the Listbox widget and turn
|
# Tricky: take the class bindings for the Listbox widget and turn
|
# them into Multibox bindings that directly run our bindings. That
|
# them into Multibox bindings that directly run our bindings. That
|
# way any binding on any of our children will automatically work the
|
# way any binding on any of our children will automatically work the
|
# right way.
|
# right way.
|
# FIXME: this loses if any Listbox bindings are added later.
|
# FIXME: this loses if any Listbox bindings are added later.
|
# To really fix we need Uhler's change to support megawidgets.
|
# To really fix we need Uhler's change to support megawidgets.
|
foreach seq [bind Listbox] {
|
foreach seq [bind Listbox] {
|
regsub -all -- %W [bind Listbox $seq] {[winfo parent %W]} sub
|
regsub -all -- %W [bind Listbox $seq] {[winfo parent %W]} sub
|
bind Multibox $seq $sub
|
bind Multibox $seq $sub
|
}
|
}
|
|
|
constructor {config} {
|
constructor {config} {
|
# The standard widget-making trick.
|
# The standard widget-making trick.
|
set class [$this info class]
|
set class [$this info class]
|
set hull [namespace tail $this]
|
set hull [namespace tail $this]
|
set old_name $this
|
set old_name $this
|
::rename $this $this-tmp-
|
::rename $this $this-tmp-
|
::frame $hull -class $class -relief flat -borderwidth 0
|
::frame $hull -class $class -relief flat -borderwidth 0
|
::rename $hull $old_name-win-
|
::rename $hull $old_name-win-
|
::rename $this $old_name
|
::rename $this $old_name
|
|
|
scrollbar [namespace tail $this].vs -orient vertical
|
scrollbar [namespace tail $this].vs -orient vertical
|
bind [namespace tail $this].vs <Destroy> [list $this delete]
|
bind [namespace tail $this].vs <Destroy> [list $this delete]
|
|
|
grid rowconfigure [namespace tail $this] 0 -weight 0
|
grid rowconfigure [namespace tail $this] 0 -weight 0
|
grid rowconfigure [namespace tail $this] 1 -weight 1
|
grid rowconfigure [namespace tail $this] 1 -weight 1
|
}
|
}
|
|
|
destructor {
|
destructor {
|
destroy $this
|
destroy $this
|
}
|
}
|
|
|
#
|
#
|
# Our interface.
|
# Our interface.
|
#
|
#
|
|
|
# Add a new column.
|
# Add a new column.
|
method add {args} {
|
method add {args} {
|
# The first array set sets up the default values, and the second
|
# The first array set sets up the default values, and the second
|
# overwrites with what the user wants.
|
# overwrites with what the user wants.
|
array set opts {-width 20 -fix 0 -title Zardoz}
|
array set opts {-width 20 -fix 0 -title Zardoz}
|
array set opts $args
|
array set opts $args
|
|
|
set num [llength $_listboxen]
|
set num [llength $_listboxen]
|
listbox [namespace tail $this].box$num -exportselection 0 -height $height \
|
listbox [namespace tail $this].box$num -exportselection 0 -height $height \
|
-selectmode $selectmode -width $opts(-width)
|
-selectmode $selectmode -width $opts(-width)
|
if {$num == 0} then {
|
if {$num == 0} then {
|
[namespace tail $this].box$num configure -yscrollcommand [list [namespace tail $this].vs set]
|
[namespace tail $this].box$num configure -yscrollcommand [list [namespace tail $this].vs set]
|
[namespace tail $this].vs configure -command [list $this yview]
|
[namespace tail $this].vs configure -command [list $this yview]
|
}
|
}
|
label [namespace tail $this].label$num -text $opts(-title) -anchor w
|
label [namespace tail $this].label$num -text $opts(-title) -anchor w
|
|
|
# No more class bindings.
|
# No more class bindings.
|
set tag_list [bindtags [namespace tail $this].box$num]
|
set tag_list [bindtags [namespace tail $this].box$num]
|
set index [lsearch -exact $tag_list Listbox]
|
set index [lsearch -exact $tag_list Listbox]
|
bindtags [namespace tail $this].box$num [lreplace $tag_list $index $index Multibox]
|
bindtags [namespace tail $this].box$num [lreplace $tag_list $index $index Multibox]
|
|
|
grid [namespace tail $this].label$num -row 0 -column $num -sticky new
|
grid [namespace tail $this].label$num -row 0 -column $num -sticky new
|
grid [namespace tail $this].box$num -row 1 -column $num -sticky news
|
grid [namespace tail $this].box$num -row 1 -column $num -sticky news
|
if {$opts(-fix)} then {
|
if {$opts(-fix)} then {
|
grid columnconfigure [namespace tail $this] $num -weight 0 \
|
grid columnconfigure [namespace tail $this] $num -weight 0 \
|
-minsize [winfo reqwidth [namespace tail $this].box$num]
|
-minsize [winfo reqwidth [namespace tail $this].box$num]
|
} else {
|
} else {
|
grid columnconfigure [namespace tail $this] $num -weight 1
|
grid columnconfigure [namespace tail $this] $num -weight 1
|
}
|
}
|
|
|
lappend _listboxen [namespace tail $this].box$num
|
lappend _listboxen [namespace tail $this].box$num
|
|
|
# Move the scrollbar over.
|
# Move the scrollbar over.
|
incr num
|
incr num
|
grid [namespace tail $this].vs -row 1 -column $num -sticky nsw
|
grid [namespace tail $this].vs -row 1 -column $num -sticky nsw
|
grid columnconfigure [namespace tail $this] $num -weight 0
|
grid columnconfigure [namespace tail $this] $num -weight 0
|
}
|
}
|
|
|
method configure {config} {}
|
method configure {config} {}
|
|
|
# FIXME: should handle automatically.
|
# FIXME: should handle automatically.
|
method cget {option} {
|
method cget {option} {
|
switch -- $option {
|
switch -- $option {
|
-selectmode {
|
-selectmode {
|
return $selectmode
|
return $selectmode
|
}
|
}
|
-height {
|
-height {
|
return $height
|
return $height
|
}
|
}
|
|
|
default {
|
default {
|
error "option $option not supported"
|
error "option $option not supported"
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
# FIXME: this isn't ideal. But we want to support adding bindings
|
# FIXME: this isn't ideal. But we want to support adding bindings
|
# at least. A "bind" method might be better.
|
# at least. A "bind" method might be better.
|
method get_boxes {} {
|
method get_boxes {} {
|
return $_listboxen
|
return $_listboxen
|
}
|
}
|
|
|
|
|
#
|
#
|
# Methods that duplicate Listbox interface.
|
# Methods that duplicate Listbox interface.
|
#
|
#
|
|
|
method activate index {
|
method activate index {
|
_apply_all activate [list $index]
|
_apply_all activate [list $index]
|
}
|
}
|
|
|
method bbox index {
|
method bbox index {
|
error "bbox method not supported"
|
error "bbox method not supported"
|
}
|
}
|
|
|
method curselection {} {
|
method curselection {} {
|
return [_apply_first curselection {}]
|
return [_apply_first curselection {}]
|
}
|
}
|
|
|
# FIXME: In itcl 1.5, can't have a method name "delete". Sigh.
|
# FIXME: In itcl 1.5, can't have a method name "delete". Sigh.
|
method delete_hack {args} {
|
method delete_hack {args} {
|
_apply_all delete $args
|
_apply_all delete $args
|
}
|
}
|
|
|
# Return some contents. We return each item as a list of the
|
# Return some contents. We return each item as a list of the
|
# columns.
|
# columns.
|
method get {first {last {}}} {
|
method get {first {last {}}} {
|
if {$last == ""} then {
|
if {$last == ""} then {
|
set r {}
|
set r {}
|
foreach l $_listboxen {
|
foreach l $_listboxen {
|
lappend r [$l get $first]
|
lappend r [$l get $first]
|
}
|
}
|
return $r
|
return $r
|
} else {
|
} else {
|
# We do things this way so that we don't have to specially
|
# We do things this way so that we don't have to specially
|
# handle the index "end".
|
# handle the index "end".
|
foreach box $_listboxen {
|
foreach box $_listboxen {
|
set seen(var-$box) [$box get $first $last]
|
set seen(var-$box) [$box get $first $last]
|
}
|
}
|
|
|
# Tricky: we use the array indices as variable names and the
|
# Tricky: we use the array indices as variable names and the
|
# array values as values. This lets us "easily" construct the
|
# array values as values. This lets us "easily" construct the
|
# result lists.
|
# result lists.
|
set r {}
|
set r {}
|
eval foreach [array get seen] {{
|
eval foreach [array get seen] {{
|
set elt {}
|
set elt {}
|
foreach box $_listboxen {
|
foreach box $_listboxen {
|
lappend elt [set var-$box]
|
lappend elt [set var-$box]
|
}
|
}
|
lappend r $elt
|
lappend r $elt
|
}}
|
}}
|
return $r
|
return $r
|
}
|
}
|
}
|
}
|
|
|
method index index {
|
method index index {
|
return [_apply_first index [list $index]]
|
return [_apply_first index [list $index]]
|
}
|
}
|
|
|
# Insert some items. Each new item is a list of items for all
|
# Insert some items. Each new item is a list of items for all
|
# columns.
|
# columns.
|
method insert {index args} {
|
method insert {index args} {
|
if {[llength $args]} then {
|
if {[llength $args]} then {
|
set seen(_) {}
|
set seen(_) {}
|
unset seen(_)
|
unset seen(_)
|
|
|
foreach value $args {
|
foreach value $args {
|
foreach columnvalue $value lname $_listboxen {
|
foreach columnvalue $value lname $_listboxen {
|
lappend seen($lname) $columnvalue
|
lappend seen($lname) $columnvalue
|
}
|
}
|
}
|
}
|
|
|
foreach box $_listboxen {
|
foreach box $_listboxen {
|
eval $box insert $index $seen($box)
|
eval $box insert $index $seen($box)
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
method nearest y {
|
method nearest y {
|
return [_apply_first nearest [list $y]]
|
return [_apply_first nearest [list $y]]
|
}
|
}
|
|
|
method scan {option args} {
|
method scan {option args} {
|
_apply_all scan $option $args
|
_apply_all scan $option $args
|
}
|
}
|
|
|
method see index {
|
method see index {
|
_apply_all see [list $index]
|
_apply_all see [list $index]
|
}
|
}
|
|
|
method selection {option args} {
|
method selection {option args} {
|
if {$option == "includes"} then {
|
if {$option == "includes"} then {
|
return [_apply_first selection [concat $option $args]]
|
return [_apply_first selection [concat $option $args]]
|
} else {
|
} else {
|
return [_apply_all selection [concat $option $args]]
|
return [_apply_all selection [concat $option $args]]
|
}
|
}
|
}
|
}
|
|
|
method size {} {
|
method size {} {
|
return [_apply_first size {}]
|
return [_apply_first size {}]
|
}
|
}
|
|
|
method xview args {
|
method xview args {
|
error "xview method not supported"
|
error "xview method not supported"
|
}
|
}
|
|
|
method yview args {
|
method yview args {
|
if {! [llength $args]} then {
|
if {! [llength $args]} then {
|
return [_apply_first yview {}]
|
return [_apply_first yview {}]
|
} else {
|
} else {
|
return [_apply_all yview $args]
|
return [_apply_all yview $args]
|
}
|
}
|
}
|
}
|
|
|
|
|
#
|
#
|
# Private methods.
|
# Private methods.
|
#
|
#
|
|
|
# This applies METHOD to every listbox.
|
# This applies METHOD to every listbox.
|
method _apply_all {method argList} {
|
method _apply_all {method argList} {
|
foreach l $_listboxen {
|
foreach l $_listboxen {
|
eval $l $method $argList
|
eval $l $method $argList
|
}
|
}
|
}
|
}
|
|
|
# This applies METHOD to the first listbox, and returns the result.
|
# This applies METHOD to the first listbox, and returns the result.
|
method _apply_first {method argList} {
|
method _apply_first {method argList} {
|
set l [lindex $_listboxen 0]
|
set l [lindex $_listboxen 0]
|
return [eval $l $method $argList]
|
return [eval $l $method $argList]
|
}
|
}
|
}
|
}
|
|
|
