libgui/library/multibox.tcl

   1 # multibox.tcl - Multi-column listbox.
   2 # Copyright (C) 1997 Cygnus Solutions.
   3 # Written by Tom Tromey <tromey@cygnus.com>.
   4
   5 # FIXME:
   6 # * Should support sashes so user can repartition widget sizes.
   7 # * Should support itemcget, itemconfigure.
   8
   9 itcl_class Multibox {
  10   # The selection mode.
  11   public selectmode browse {
  12     _apply_all configure [list -selectmode $selectmode]
  13   }
  14
  15   # The height.
  16   public height 10 {
  17     _apply_all configure [list -height $height]
  18   }
  19
  20   # This is a list of all the listbox widgets we've created.  Private
  21   # variable.
  22   protected _listboxen {}
  23
  24   # Tricky: take the class bindings for the Listbox widget and turn
  25   # them into Multibox bindings that directly run our bindings.  That
  26   # way any binding on any of our children will automatically work the
  27   # right way.
  28   # FIXME: this loses if any Listbox bindings are added later.
  29   # To really fix we need Uhler's change to support megawidgets.
  30   foreach seq [bind Listbox] {
  31     regsub -all -- %W [bind Listbox $seq] {[winfo parent %W]} sub
  32     bind Multibox $seq $sub
  33   }
  34
  35   constructor {config} {
  36     # The standard widget-making trick.
  37     set class [$this info class]
  38     set hull [namespace tail $this]
  39     set old_name $this
  40     ::rename $this $this-tmp-
  41     ::frame $hull -class $class -relief flat -borderwidth 0
  42     ::rename $hull $old_name-win-
  43     ::rename $this $old_name
  44
  45     scrollbar [namespace tail $this].vs -orient vertical
  46     bind [namespace tail $this].vs <Destroy> [list $this delete]
  47
  48     grid rowconfigure  [namespace tail $this] 0 -weight 0
  49     grid rowconfigure  [namespace tail $this] 1 -weight 1
  50   }
  51
  52   destructor {
  53     destroy $this
  54   }
  55
  56   #
  57   # Our interface.
  58   #
  59
  60   # Add a new column.
  61   method add {args} {
  62     # The first array set sets up the default values, and the second
  63     # overwrites with what the user wants.
  64     array set opts {-width 20 -fix 0 -title Zardoz}
  65     array set opts $args
  66
  67     set num [llength $_listboxen]
  68     listbox [namespace tail $this].box$num -exportselection 0 -height $height \
  69       -selectmode $selectmode -width $opts(-width)
  70     if {$num == 0} then {
  71       [namespace tail $this].box$num configure -yscrollcommand [list [namespace tail $this].vs set]
  72       [namespace tail $this].vs configure -command [list $this yview]
  73     }
  74     label [namespace tail $this].label$num -text $opts(-title) -anchor w
  75
  76     # No more class bindings.
  77     set tag_list [bindtags [namespace tail $this].box$num]
  78     set index [lsearch -exact $tag_list Listbox]
  79     bindtags [namespace tail $this].box$num [lreplace $tag_list $index $index Multibox]
  80
  81     grid [namespace tail $this].label$num -row 0 -column $num -sticky new
  82     grid [namespace tail $this].box$num -row 1 -column $num -sticky news
  83     if {$opts(-fix)} then {
  84       grid columnconfigure  [namespace tail $this] $num -weight 0 \
  85         -minsize [winfo reqwidth [namespace tail $this].box$num]
  86     } else {
  87       grid columnconfigure  [namespace tail $this] $num -weight 1
  88     }
  89
  90     lappend _listboxen [namespace tail $this].box$num
  91
  92     # Move the scrollbar over.
  93     incr num
  94     grid [namespace tail $this].vs -row 1 -column $num -sticky nsw
  95     grid columnconfigure  [namespace tail $this] $num -weight 0
  96   }
  97
  98   method configure {config} {}
  99
 100   # FIXME: should handle automatically.
 101   method cget {option} {
 102     switch -- $option {
 103       -selectmode {
 104         return $selectmode
 105       }
 106       -height {
 107         return $height
 108       }
 109
 110       default {
 111         error "option $option not supported"
 112       }
 113     }
 114   }
 115
 116   # FIXME: this isn't ideal.  But we want to support adding bindings
 117   # at least.  A "bind" method might be better.
 118   method get_boxes {} {
 119     return $_listboxen
 120   }
 121
 122
 123   #
 124   # Methods that duplicate Listbox interface.
 125   #
 126
 127   method activate index {
 128     _apply_all activate [list $index]
 129   }
 130
 131   method bbox index {
 132     error "bbox method not supported"
 133   }
 134
 135   method curselection {} {
 136     return [_apply_first curselection {}]
 137   }
 138
 139   # FIXME: In itcl 1.5, can't have a method name "delete".  Sigh.
 140   method delete_hack {args} {
 141     _apply_all delete $args
 142   }
 143
 144   # Return some contents.  We return each item as a list of the
 145   # columns.
 146   method get {first {last {}}} {
 147     if {$last == ""} then {
 148       set r {}
 149       foreach l $_listboxen {
 150         lappend r [$l get $first]
 151       }
 152       return $r
 153     } else {
 154       # We do things this way so that we don't have to specially
 155       # handle the index "end".
 156       foreach box $_listboxen {
 157         set seen(var-$box) [$box get $first $last]
 158       }
 159
 160       # Tricky: we use the array indices as variable names and the
 161       # array values as values.  This lets us "easily" construct the
 162       # result lists.
 163       set r {}
 164       eval foreach [array get seen] {{
 165         set elt {}
 166         foreach box $_listboxen {
 167           lappend elt [set var-$box]
 168         }
 169         lappend r $elt
 170       }}
 171       return $r
 172     }
 173   }
 174
 175   method index index {
 176     return [_apply_first index [list $index]]
 177   }
 178
 179   # Insert some items.  Each new item is a list of items for all
 180   # columns.
 181   method insert {index args} {
 182     if {[llength $args]} then {
 183       set seen(_) {}
 184       unset seen(_)
 185
 186       foreach value $args {
 187         foreach columnvalue $value lname $_listboxen {
 188           lappend seen($lname) $columnvalue
 189         }
 190       }
 191
 192       foreach box $_listboxen {
 193         eval $box insert $index $seen($box)
 194       }
 195     }
 196   }
 197
 198   method nearest y {
 199     return [_apply_first nearest [list $y]]
 200   }
 201
 202   method scan {option args} {
 203     _apply_all scan $option $args
 204   }
 205
 206   method see index {
 207     _apply_all see [list $index]
 208   }
 209
 210   method selection {option args} {
 211     if {$option == "includes"} then {
 212       return [_apply_first selection [concat $option $args]]
 213     } else {
 214       return [_apply_all selection [concat $option $args]]
 215     }
 216   }
 217
 218   method size {} {
 219     return [_apply_first size {}]
 220   }
 221
 222   method xview args {
 223     error "xview method not supported"
 224   }
 225
 226   method yview args {
 227     if {! [llength $args]} then {
 228       return [_apply_first yview {}]
 229     } else {
 230       return [_apply_all yview $args]
 231     }
 232   }
 233
 234
 235   #
 236   # Private methods.
 237   #
 238
 239   # This applies METHOD to every listbox.
 240   method _apply_all {method argList} {
 241     foreach l $_listboxen {
 242       eval $l $method $argList
 243     }
 244   }
 245
 246   # This applies METHOD to the first listbox, and returns the result.
 247   method _apply_first {method argList} {
 248     set l [lindex $_listboxen 0]
 249     return [eval $l $method $argList]
 250   }
 251 }