1 # Copyright (c) 1999, Bryan Oakley
2 # All Rights Reservered
5 # oakley@channelpoint.com
7 # mclistbox v1.02 March 30, 1999
9 # a multicolumn listbox written in pure tcl
11 # this code is freely distributable without restriction, but is
12 # provided as-is with no waranty expressed or implied.
16 # mclistbox::mclistbox .listbox
17 # .listbox column add col1 -label "Column 1"
18 # .listbox column add col2 -label "Column 2"
19 # .listbox insert end [list "some stuff" "some more stuff"]
20 # .listbox insert end [list "a second row of stuff" "blah blah blah"]
22 # see the documentation for more, uh, documentation.
24 # Something to think about: implement a "-optimize" option, with two
25 # values: speed and memory. If set to speed, keep a copy of the data
26 # in our hidden listbox so retrieval of data doesn't require us to
27 # do all the getting and splitting and so forth. If set to "memory",
28 # bag saving a duplicate copy of the data, which means data retrieval
29 # will be slower, but memory requirements will be reduced.
31 package require Tk 8.0
32 package provide mclistbox 1.02
34 namespace eval ::mclistbox {
36 # this is the public interface
37 namespace export mclistbox
39 # these contain references to available options
40 variable widgetOptions
41 variable columnOptions
43 # these contain references to available commands and subcommands
44 variable widgetCommands
45 variable columnCommands
46 variable labelCommands
49 # ::mclistbox::Init --
51 # Initialize the global (well, namespace) variables. This should
52 # only be called once, immediately prior to creating the first
53 # instance of the widget
57 # All state variables are set to their default values; all of
58 # the option database entries will exist.
64 proc ::mclistbox::Init {} {
65 variable widgetOptions
66 variable columnOptions
67 variable widgetCommands
68 variable columnCommands
69 variable labelCommands
71 # here we match up command line options with option database names
72 # and classes. As it turns out, this is a handy reference of all of the
73 # available options. Note that if an item has a value with only one
74 # item (like -bd, for example) it is a synonym and the value is the
77 array set widgetOptions [list \
78 -background {background Background} \
81 -borderwidth {borderWidth BorderWidth} \
82 -columnbd -columnborderwidth \
83 -columnborderwidth {columnBorderWidth BorderWidth} \
84 -columnrelief {columnRelief Relief} \
85 -cursor {cursor Cursor} \
86 -exportselection {exportSelection ExportSelection} \
88 -fillcolumn {fillColumn FillColumn} \
90 -foreground {foreground Foreground} \
91 -height {height Height} \
92 -highlightbackground {highlightBackground HighlightBackground} \
93 -highlightcolor {highlightColor HighlightColor} \
94 -highlightthickness {highlightThickness HighlightThickness} \
95 -labelanchor {labelAnchor Anchor} \
96 -labelbackground {labelBackground Background} \
97 -labelbd -labelborderwidth \
98 -labelbg -labelbackground \
99 -labelborderwidth {labelBorderWidth BorderWidth} \
100 -labelfg -labelforeground \
101 -labelfont {labelFont Font} \
102 -labelforeground {labelForeground Foreground} \
103 -labelheight {labelHeight Height} \
104 -labelimage {labelImage Image} \
105 -labelrelief {labelRelief Relief} \
106 -labels {labels Labels} \
107 -relief {relief Relief} \
108 -resizablecolumns {resizableColumns ResizableColumns} \
109 -selectbackground {selectBackground Foreground} \
110 -selectborderwidth {selectBorderWidth BorderWidth} \
111 -selectcommand {selectCommand Command} \
112 -selectforeground {selectForeground Background} \
113 -selectmode {selectMode SelectMode} \
114 -setgrid {setGrid SetGrid} \
115 -takefocus {takeFocus TakeFocus} \
116 -width {width Width} \
117 -xscrollcommand {xScrollCommand ScrollCommand} \
118 -yscrollcommand {yScrollCommand ScrollCommand} \
121 # and likewise for column-specific stuff.
122 array set columnOptions [list \
123 -background {background Background} \
124 -bitmap {bitmap Bitmap} \
126 -foreground {foreground Foreground} \
127 -image {image Image} \
128 -label {label Label} \
129 -position {position Position} \
130 -resizable {resizable Resizable} \
131 -visible {visible Visible} \
132 -width {width Width} \
135 # this defines the valid widget commands. It's important to
136 # list them here; we use this list to validate commands and
137 # expand abbreviations.
138 set widgetCommands [list \
139 activate bbox cget column configure \
140 curselection delete get index insert \
141 label nearest scan see selection \
145 set columnCommands [list add cget configure delete names nearest]
146 set labelCommands [list bind]
148 ######################################################################
149 #- this initializes the option database. Kinda gross, but it works
151 ######################################################################
153 set packages [package names]
155 # why check for the Tk package? This lets us be sourced into
156 # an interpreter that doesn't have Tk loaded, such as the slave
157 # interpreter used by pkg_mkIndex. In theory it should have no
158 # side effects when run
159 if {[lsearch -exact [package names] "Tk"] != -1} {
161 # compute a widget name we can use to create a temporary widget
162 set tmpWidget ".__tmp__"
164 while {[winfo exists $tmpWidget] == 1} {
165 set tmpWidget ".__tmp__$count"
169 # steal options from the listbox
170 # we want darn near all options, so we'll go ahead and do
171 # them all. No harm done in adding the one or two that we
174 foreach foo [$tmpWidget configure] {
175 if {[llength $foo] == 5} {
176 set option [lindex $foo 1]
177 set value [lindex $foo 4]
178 option add *Mclistbox.$option $value widgetDefault
180 # these options also apply to the individual columns...
181 if {[string compare $option "foreground"] == 0 \
182 || [string compare $option "background"] == 0 \
183 || [string compare $option "font"] == 0} {
184 option add *Mclistbox*MclistboxColumn.$option $value \
191 # steal some options from label widgets; we only want a subset
192 # so we'll use a slightly different method. No harm in *not*
193 # adding in the one or two that we don't use... :-)
195 foreach option [list Anchor Background Font \
196 Foreground Height Image ] {
197 set values [$tmpWidget configure -[string tolower $option]]
198 option add *Mclistbox.label$option [lindex $values 3]
202 # these are unique to us...
203 option add *Mclistbox.columnBorderWidth 0 widgetDefault
204 option add *Mclistbox.columnRelief flat widgetDefault
205 option add *Mclistbox.labelBorderWidth 1 widgetDefault
206 option add *Mclistbox.labelRelief raised widgetDefault
207 option add *Mclistbox.labels 1 widgetDefault
208 option add *Mclistbox.resizableColumns 1 widgetDefault
209 option add *Mclistbox.selectcommand {} widgetDefault
210 option add *Mclistbox.fillcolumn {} widgetDefault
213 option add *Mclistbox*MclistboxColumn.visible 1 widgetDefault
214 option add *Mclistbox*MclistboxColumn.resizable 1 widgetDefault
215 option add *Mclistbox*MclistboxColumn.position end widgetDefault
216 option add *Mclistbox*MclistboxColumn.label "" widgetDefault
217 option add *Mclistbox*MclistboxColumn.width 0 widgetDefault
218 option add *Mclistbox*MclistboxColumn.bitmap "" widgetDefault
219 option add *Mclistbox*MclistboxColumn.image "" widgetDefault
222 ######################################################################
223 # define the class bindings
224 ######################################################################
230 # ::mclistbox::mclistbox --
232 # This is the command that gets exported. It creates a new
237 # w path of new widget to create
238 # args additional option/value pairs (eg: -background white, etc.)
242 # It creates the widget and sets up all of the default bindings
246 # The name of the newly create widget
248 proc ::mclistbox::mclistbox {args} {
249 variable widgetOptions
251 # perform a one time initialization
252 if {![info exists widgetOptions]} {
256 # make sure we at least have a widget name
257 if {[llength $args] == 0} {
258 error "wrong # args: should be \"mclistbox pathName ?options?\""
261 # ... and make sure a widget doesn't already exist by that name
262 if {[winfo exists [lindex $args 0]]} {
263 error "window name \"[lindex $args 0]\" already exists"
266 # and check that all of the args are valid
267 foreach {name value} [lrange $args 1 end] {
268 Canonize [lindex $args 0] option $name
272 set w [eval Build $args]
274 # set some bindings...
281 # ::mclistbox::Build --
283 # This does all of the work necessary to create the basic
289 # args additional option/value pairs
293 # Creates a new widget with the given name. Also creates a new
294 # namespace patterened after the widget name, as a child namespace
299 # the name of the widget
301 proc ::mclistbox::Build {w args} {
302 variable widgetOptions
304 # create the namespace for this instance, and define a few
306 namespace eval ::mclistbox::$w {
313 # this gives us access to the namespace variables within
315 upvar ::mclistbox::${w}::widgets widgets
316 upvar ::mclistbox::${w}::options options
317 upvar ::mclistbox::${w}::misc misc
319 # initially we start out with no columns
322 # this is our widget -- a frame of class Mclistbox. Naturally,
323 # it will contain other widgets. We create it here because
324 # we need it to be able to set our default options.
325 set widgets(this) [frame $w -class Mclistbox -takefocus 1]
327 # this defines all of the default options. We get the
328 # values from the option database. Note that if an array
329 # value is a list of length one it is an alias to another
330 # option, so we just ignore it
331 foreach name [array names widgetOptions] {
332 if {[llength $widgetOptions($name)] == 1} continue
333 set optName [lindex $widgetOptions($name) 0]
334 set optClass [lindex $widgetOptions($name) 1]
335 set options($name) [option get $w $optName $optClass]
338 # now apply any of the options supplied on the command
339 # line. This may overwrite our defaults, which is OK
340 if {[llength $args] > 0} {
341 array set options $args
344 # the columns all go into a text widget since it has the
346 set widgets(text) [text $w.text \
353 -highlightthickness 0 \
358 $widgets(text) configure -state disabled
360 # here's the tricky part (shhhh... don't tell anybody!)
361 # we are going to create column that completely fills
362 # the base frame. We will use it to control the sizing
363 # of the widget. The trick is, we'll pack it in the frame
364 # and then place the text widget over it so it is never
367 set columnWidgets [NewColumn $w {__hidden__}]
368 set widgets(hiddenFrame) [lindex $columnWidgets 0]
369 set widgets(hiddenListbox) [lindex $columnWidgets 1]
370 set widgets(hiddenLabel) [lindex $columnWidgets 2]
372 # by default geometry propagation is turned off, but for this
373 # super-secret widget we want it turned on. The idea is, we
374 # resize the listbox which resizes the frame which resizes the
376 pack propagate $widgets(hiddenFrame) on
378 pack $widgets(hiddenFrame) -side top -fill both -expand y
379 place $widgets(text) -x 0 -y 0 -relwidth 1.0 -relheight 1.0
382 # we will later rename the frame's widget proc to be our
383 # own custom widget proc. We need to keep track of this
384 # new name, so we'll define and store it here...
385 set widgets(frame) ::mclistbox::${w}::$w
387 # this moves the original frame widget proc into our
388 # namespace and gives it a handy name
389 rename ::$w $widgets(frame)
391 # now, create our widget proc. Obviously (?) it goes in
392 # the global namespace. All mclistbox widgets will actually
393 # share the same widget proc to cut down on the amount of
395 proc ::$w {command args} \
396 "eval ::mclistbox::WidgetProc {$w} \$command \$args"
398 # ok, the thing exists... let's do a bit more configuration.
399 if {[catch "Configure $widgets(this) [array get options]" error]} {
403 # and be prepared to handle selections.. (this, for -exportselection
405 selection handle $w [list ::mclistbox::SelectionHandler $w get]
410 # ::mclistbox::SelectionHandler --
412 # handle reqests to set or retrieve the primary selection. This is
413 # the "guts" of the implementation of the -exportselection option.
414 # What a pain! Note that this command is *not* called as a result
415 # of the widget's "selection" command, but rather as a result of
416 # the global selection being set or cleared.
418 # If I read the ICCCM correctly (which is doubtful; who has time to
419 # read that thing thoroughly?), this should return each row as a tab
420 # separated list of values, and the whole as a newline separated
425 # w pathname of the widget
426 # type one of "own", "lose" or "get"
427 # offset only used if type is "get"; offset into the selection
428 # buffer where the returned data should begin
429 # length number of bytes to return
432 proc ::mclistbox::SelectionHandler {w type {offset ""} {length ""}} {
433 upvar ::mclistbox::${w}::options options
434 upvar ::mclistbox::${w}::misc misc
435 upvar ::mclistbox::${w}::widgets widgets
437 switch -exact $type {
441 -command [list ::mclistbox::SelectionHandler $w lose] \
447 if {$options(-exportselection)} {
448 foreach id $misc(columns) {
449 $widgets(listbox$id) selection clear 0 end
455 set end [expr {$length + $offset - 1}]
457 set column [lindex $misc(columns) 0]
458 set curselection [$widgets(listbox$column) curselection]
460 # this is really, really slow (relatively speaking).
461 # but the only way I can think of to speed this up
462 # is to duplicate all the data in our hidden listbox,
463 # which I really don't want to do because of memory
466 foreach index $curselection {
467 set rowdata [join [::mclistbox::WidgetProc-get $w $index] "\t"]
468 lappend data $rowdata
470 set data [join $data "\n"]
471 return [string range $data $offset $end]
477 # ::mclistbox::convert --
479 # public routine to convert %x, %y and %W binding substitutions.
480 # Given an x, y and or %W value relative to a given widget, this
481 # routine will convert the values to be relative to the mclistbox
482 # widget. For example, it could be used in a binding like this:
484 # bind .mclistbox <blah> {doSomething [::mclistbox::convert %W -x %x]}
486 # Note that this procedure is *not* exported, but is indented for
487 # public use. It is not exported because the name could easily
488 # clash with existing commands.
492 # w a widget path; typically the actual result of a %W
493 # substitution in a binding. It should be either a
494 # mclistbox widget or one of its subwidgets
496 # args should one or more of the following arguments or
497 # pairs of arguments:
499 # -x <x> will convert the value <x>; typically <x> will
500 # be the result of a %x substitution
501 # -y <y> will convert the value <y>; typically <y> will
502 # be the result of a %y substitution
503 # -W (or -w) will return the name of the mclistbox widget
504 # which is the parent of $w
508 # a list of the requested values. For example, a single -w will
509 # result in a list of one items, the name of the mclistbox widget.
510 # Supplying "-x 10 -y 20 -W" (in any order) will return a list of
511 # three values: the converted x and y values, and the name of
512 # the mclistbox widget.
514 proc ::mclistbox::convert {w args} {
516 if {![winfo exists $w]} {
517 error "window \"$w\" doesn't exist"
520 while {[llength $args] > 0} {
521 set option [lindex $args 0]
522 set args [lrange $args 1 end]
524 switch -exact -- $option {
526 set value [lindex $args 0]
527 set args [lrange $args 1 end]
529 while {[winfo class $win] != "Mclistbox"} {
530 incr value [winfo x $win]
531 set win [winfo parent $win]
532 if {$win == "."} break
534 lappend result $value
538 set value [lindex $args 0]
539 set args [lrange $args 1 end]
541 while {[winfo class $win] != "Mclistbox"} {
542 incr value [winfo y $win]
543 set win [winfo parent $win]
544 if {$win == "."} break
546 lappend result $value
552 while {[winfo class $win] != "Mclistbox"} {
553 set win [winfo parent $win]
554 if {$win == "."} break;
563 # ::mclistbox::SetBindings --
565 # Sets up the default bindings for the named widget
569 # w the widget pathname for which the bindings should be assigned
573 # The named widget will inheirit all of the default Mclistbox
576 proc ::mclistbox::SetBindings {w} {
577 upvar ::mclistbox::${w}::widgets widgets
578 upvar ::mclistbox::${w}::options options
579 upvar ::mclistbox::${w}::misc misc
581 # we must do this so that the columns fill the text widget in
583 bind $widgets(text) <Configure> \
584 [list ::mclistbox::AdjustColumns $w %h]
588 # ::mclistbox::SetClassBindings --
590 # Sets up the default bindings for the widget class
597 proc ::mclistbox::SetClassBindings {} {
598 # this allows us to clean up some things when we go away
599 bind Mclistbox <Destroy> [list ::mclistbox::DestroyHandler %W]
601 # steal all of the standard listbox bindings. Note that if a user
602 # clicks in a column, %W will return that column. This is bad,
603 # so we have to make a substitution in all of the bindings to
604 # compute the real widget name (ie: the name of the topmost
606 foreach event [bind Listbox] {
607 set binding [bind Listbox $event]
608 regsub -all {%W} $binding {[::mclistbox::convert %W -W]} binding
609 regsub -all {%x} $binding {[::mclistbox::convert %W -x %x]} binding
610 regsub -all {%y} $binding {[::mclistbox::convert %W -y %y]} binding
611 bind Mclistbox $event $binding
614 # these define bindings for the column labels for resizing. Note
615 # that we need both the name of this widget (calculated by $this)
616 # as well as the specific widget that the event occured over.
617 # Also note that $this is a constant string that gets evaluated
618 # when the binding fires.
620 set this {[::mclistbox::convert %W -W]}
621 bind MclistboxMouseBindings <ButtonPress-1> \
622 "::mclistbox::ResizeEvent $this buttonpress %W %x %X %Y"
623 bind MclistboxMouseBindings <ButtonRelease-1> \
624 "::mclistbox::ResizeEvent $this buttonrelease %W %x %X %Y"
625 bind MclistboxMouseBindings <Enter> \
626 "::mclistbox::ResizeEvent $this motion %W %x %X %Y"
627 bind MclistboxMouseBindings <Motion> \
628 "::mclistbox::ResizeEvent $this motion %W %x %X %Y"
629 bind MclistboxMouseBindings <B1-Motion> \
630 "::mclistbox::ResizeEvent $this drag %W %x %X %Y"
633 # ::mclistbox::NewColumn --
635 # Adds a new column to the mclistbox widget
639 # w the widget pathname
640 # id the id for the new column
644 # Creates a set of widgets which defines the column. Adds
645 # appropriate entries to the global array widgets for the
648 # Note that this column is not added to the listbox by
653 # A list of three elements: the path to the column frame,
654 # the path to the column listbox, and the path to the column
655 # label, in that order.
657 proc ::mclistbox::NewColumn {w id} {
658 upvar ::mclistbox::${w}::widgets widgets
659 upvar ::mclistbox::${w}::options options
660 upvar ::mclistbox::${w}::misc misc
661 upvar ::mclistbox::${w}::columnID columnID
663 # the columns are all children of the text widget we created...
667 -highlightthickness 0 \
668 -class MclistboxColumn \
669 -background $options(-background) \
673 [listbox $frame.listbox \
676 -setgrid $options(-setgrid) \
677 -exportselection false \
678 -selectmode $options(-selectmode) \
679 -highlightthickness 0 \
683 [label $frame.label \
687 -highlightthickness 0 \
690 # define mappings from widgets to columns
691 set columnID($label) $id
692 set columnID($frame) $id
693 set columnID($listbox) $id
695 # we're going to associate a new bindtag for the label to
696 # handle our resize bindings. Why? We want the bindings to
697 # be specific to this widget but we don't want to use the
698 # widget name. If we use the widget name then the bindings
699 # could get mixed up with user-supplied bindigs (via the
700 # "label bind" command).
701 set tag MclistboxLabel
702 bindtags $label [list MclistboxMouseBindings $label]
704 # reconfigure the label based on global options
705 foreach option [list bd image height relief font anchor \
706 background foreground borderwidth] {
707 if {[info exists options(-label$option)] \
708 && $options(-label$option) != ""} {
709 $label configure -$option $options(-label$option)
713 # reconfigure the column based on global options
714 foreach option [list borderwidth relief] {
715 if {[info exists options(-column$option)] \
716 && $options(-column$option) != ""} {
717 $frame configure -$option $options(-column$option)
721 # geometry propagation must be off so we can control the size
722 # of the listbox by setting the size of the containing frame
723 pack propagate $frame off
725 pack $label -side top -fill x -expand n
726 pack $listbox -side top -fill both -expand y -pady 2
728 # any events that happen in the listbox gets handled by the class
729 # bindings. This has the unfortunate side effect
730 bindtags $listbox [list $w Mclistbox all]
732 # return a list of the widgets we created.
733 return [list $frame $listbox $label]
736 # ::mclistbox::Column-add --
738 # Implements the "column add" widget command
742 # w the widget pathname
743 # args additional option/value pairs which define the column
747 # A column gets created and added to the listbox
749 proc ::mclistbox::Column-add {w args} {
750 upvar ::mclistbox::${w}::widgets widgets
751 upvar ::mclistbox::${w}::options options
752 upvar ::mclistbox::${w}::misc misc
754 variable widgetOptions
756 set id "column-[llength $misc(columns)]" ;# a suitable default
758 # if the first argument doesn't have a "-" as the first
759 # character, it is an id to associate with this column
760 if {![string match {-*} [lindex $args 0]]} {
761 # the first arg must be an id.
762 set id [lindex $args 0]
763 set args [lrange $args 1 end]
764 if {[lsearch -exact $misc(columns) $id] != -1} {
765 error "column \"$id\" already exists"
769 # define some reasonable defaults, then add any specific
770 # values supplied by the user
774 set opts(-resizable) 1
775 set opts(-position) "end"
777 set opts(-background) $options(-background)
778 set opts(-foreground) $options(-foreground)
779 set opts(-font) $options(-font)
782 if {[expr {[llength $args]%2}] == 1} {
783 # hmmm. An odd number of elements in args
784 # if the last item is a valid option we'll give a different
785 # error than if its not
786 set option [::mclistbox::Canonize $w "column option" [lindex $args end]]
787 error "value for \"[lindex $args end]\" missing"
791 # figure out if we have any data in the listbox yet; we'll need
792 # this information in a minute...
793 if {[llength $misc(columns)] > 0} {
794 set col0 [lindex $misc(columns) 0]
795 set existingRows [$widgets(listbox$col0) size]
800 # create the widget and assign the associated paths to our array
801 set widgetlist [NewColumn $w $id]
803 set widgets(frame$id) [lindex $widgetlist 0]
804 set widgets(listbox$id) [lindex $widgetlist 1]
805 set widgets(label$id) [lindex $widgetlist 2]
807 # add this column to the list of known columns
808 lappend misc(columns) $id
810 # configure the options. As a side effect, it will be inserted
812 eval ::mclistbox::Column-configure {$w} {$id} [array get opts]
814 # now, if there is any data already in the listbox, we need to
815 # add a corresponding number of blank items. At least, I *think*
816 # that's the right thing to do.
817 if {$existingRows > 0} {
819 for {set i 0} {$i < $existingRows} {incr i} {
822 eval {$widgets(listbox$id)} insert end $blanks
825 InvalidateScrollbars $w
829 # ::mclistbox::Column-configure --
831 # Implements the "column configure" widget command
836 # id column identifier
837 # args list of option/value pairs
839 proc ::mclistbox::Column-configure {w id args} {
840 variable widgetOptions
841 variable columnOptions
843 upvar ::mclistbox::${w}::widgets widgets
844 upvar ::mclistbox::${w}::options options
845 upvar ::mclistbox::${w}::misc misc
847 # bail if they gave us a bogus id
848 set index [CheckColumnID $w $id]
850 # define some shorthand
851 set listbox $widgets(listbox$id)
852 set frame $widgets(frame$id)
853 set label $widgets(label$id)
855 if {[llength $args] == 0} {
856 # hmmm. User must be wanting all configuration information
857 # note that if the value of an array element is of length
858 # one it is an alias, which needs to be handled slightly
861 foreach opt [lsort [array names columnOptions]] {
862 if {[llength $columnOptions($opt)] == 1} {
863 set alias $columnOptions($opt)
864 set optName $columnOptions($alias)
865 lappend results [list $opt $optName]
867 set optName [lindex $columnOptions($opt) 0]
868 set optClass [lindex $columnOptions($opt) 1]
869 set default [option get $frame $optName $optClass]
870 lappend results [list $opt $optName $optClass \
871 $default $options($id:$opt)]
878 } elseif {[llength $args] == 1} {
880 # the user must be querying something... I need to get this
881 # to return a bona fide list like the "real" configure
882 # command, but it's not a priority at the moment. I still
883 # have to work on the option database support foo.
884 set option [::mclistbox::Canonize $w "column option" [lindex $args 0]]
886 set value $options($id:$option)
887 set optName [lindex $columnOptions($option) 0]
888 set optClass [lindex $columnOptions($option) 1]
889 set default [option get $frame $optName $optClass]
890 set results [list $option $optName $optClass $default $value]
895 # if we have an odd number of values, bail.
896 if {[expr {[llength $args]%2}] == 1} {
897 # hmmm. An odd number of elements in args
898 error "value for \"[lindex $args end]\" missing"
901 # Great. An even number of options. Let's make sure they
902 # are all valid before we do anything. Note that Canonize
903 # will generate an error if it finds a bogus option; otherwise
904 # it returns the canonical option name
905 foreach {name value} $args {
906 set name [::mclistbox::Canonize $w "column option" $name]
907 set opts($name) $value
910 # if we get to here, the user is wanting to set some options
911 foreach option [array names opts] {
912 set value $opts($option)
913 set options($id:$option) $value
917 $label configure -text $value
922 $label configure $option $value
926 set font [$listbox cget -font]
927 set factor [font measure $options(-font) "0"]
928 set width [expr {$value * $factor}]
930 $widgets(frame$id) configure -width $width
931 set misc(min-$widgets(frame$id)) $width
937 if {[string length $value] == 0} {set value $options($option)}
938 $listbox configure $option $value
944 set options($id:-resizable) 1
946 set options($id:-resizable) 0
949 error "expected boolean but got \"$value\""
956 set options($id:-visible) 1
957 $widgets(text) configure -state normal
958 $widgets(text) window configure 1.$index -window $frame
959 $widgets(text) configure -state disabled
962 set options($id:-visible) 0
963 $widgets(text) configure -state normal
964 $widgets(text) window configure 1.$index -window {}
965 $widgets(text) configure -state disabled
967 InvalidateScrollbars $w
969 error "expected boolean but got \"$value\""
975 if {[string compare $value "start"] == 0} {
978 } elseif {[string compare $value "end"] == 0} {
980 set position [expr {[llength $misc(columns)] -1}]
983 # ought to check for a legal value here, but I'm
988 if {$position >= [llength $misc(columns)]} {
989 set max [expr {[llength $misc(columns)] -1}]
990 error "bad position; must be in the range of 0-$max"
993 # rearrange misc(columns) to reflect the new ordering
994 set current [lsearch -exact $misc(columns) $id]
995 set misc(columns) [lreplace $misc(columns) $current $current]
996 set misc(columns) [linsert $misc(columns) $position $id]
998 set frame $widgets(frame$id)
999 $widgets(text) configure -state normal
1000 $widgets(text) window create 1.$position \
1001 -window $frame -stretch 1
1002 $widgets(text) configure -state disabled
1010 # ::mclistbox::DestroyHandler {w} --
1012 # Cleans up after a mclistbox widget is destroyed
1020 # The namespace that was created for the widget is deleted,
1021 # and the widget proc is removed.
1023 proc ::mclistbox::DestroyHandler {w} {
1025 # kill off any idle event we might have pending
1026 if {[info exists ::mclistbox::${w}::misc(afterid)]} {
1028 after cancel $::mclistbox::${w}::misc(afterid)
1029 unset ::mclistbox::${w}::misc(afterid)
1033 # if the widget actually being destroyed is of class Mclistbox,
1034 # crush the namespace and kill the proc. Get it? Crush. Kill.
1035 # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it
1036 # brings tears to my eyes.
1037 if {[string compare [winfo class $w] "Mclistbox"] == 0} {
1038 namespace delete ::mclistbox::$w
1044 # ::mclistbox::MassageIndex --
1046 # this proc massages indicies of the form @x,y such that
1047 # the coordinates are relative to the first listbox rather
1048 # than relative to the topmost frame.
1053 # index an index of the form @x,y
1057 # Returns a new index with translated coordinates. This index
1058 # may be used directly by an internal listbox.
1060 proc ::mclistbox::MassageIndex {w index} {
1061 upvar ::mclistbox::${w}::widgets widgets
1062 upvar ::mclistbox::${w}::misc misc
1064 if {[regexp {@([0-9]+),([0-9]+)} $index matchvar x y]} {
1065 set id [lindex $misc(columns) 0]
1067 incr y -[winfo y $widgets(listbox$id)]
1068 incr y -[winfo y $widgets(frame$id)]
1069 incr x [winfo x $widgets(listbox$id)]
1070 incr x [winfo x $widgets(frame$id)]
1072 set index @${x},${y}
1078 # ::mclistbox::WidgetProc --
1080 # This gets uses as the widgetproc for an mclistbox widget.
1081 # Notice where the widget is created and you'll see that the
1082 # actual widget proc merely evals this proc with all of the
1085 # Note that some widget commands are defined "inline" (ie:
1086 # within this proc), and some do most of their work in
1087 # separate procs. This is merely because sometimes it was
1088 # easier to do it one way or the other.
1093 # command widget subcommand
1094 # args additional arguments; varies with the subcommand
1098 # Performs the requested widget command
1100 proc ::mclistbox::WidgetProc {w command args} {
1101 variable widgetOptions
1103 upvar ::mclistbox::${w}::widgets widgets
1104 upvar ::mclistbox::${w}::options options
1105 upvar ::mclistbox::${w}::misc misc
1106 upvar ::mclistbox::${w}::columnID columnID
1108 set command [::mclistbox::Canonize $w command $command]
1110 # some commands have subcommands. We'll check for that here
1111 # and mung the command and args so that we can treat them as
1112 # distinct commands in the following switch statement
1113 if {[string compare $command "column"] == 0} {
1114 set subcommand [::mclistbox::Canonize $w "column command" \
1116 set command "$command-$subcommand"
1117 set args [lrange $args 1 end]
1119 } elseif {[string compare $command "label"] == 0} {
1120 set subcommand [::mclistbox::Canonize $w "label command" \
1122 set command "$command-$subcommand"
1123 set args [lrange $args 1 end]
1127 catch {unset priorSelection}
1129 # here we go. Error checking be damned!
1132 # note that at present, "xview <index>" is broken. I'm
1133 # not even sure how to do it. Unless I attach our hidden
1134 # listbox to the scrollbar and use it. Hmmm..... I'll
1135 # try that later. (FIXME)
1136 set result [eval {$widgets(text)} xview $args]
1137 InvalidateScrollbars $w
1141 if {[llength $args] == 0} {
1142 # length of zero means to fetch the yview; we can
1143 # get this from a single listbox
1144 set result [$widgets(hiddenListbox) yview]
1148 # if it's one argument, it's an index. We'll pass that
1149 # index through the index command to properly translate
1150 # @x,y indicies, and place the value back in args
1151 if {[llength $args] == 1} {
1152 set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1153 set args [list $index]
1156 # run the yview command on every column.
1157 foreach id $misc(columns) {
1158 eval {$widgets(listbox$id)} yview $args
1160 eval {$widgets(hiddenListbox)} yview $args
1162 InvalidateScrollbars $w
1169 if {[llength $args] != 1} {
1170 error "wrong \# of args: should be $w activate index"
1172 set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1174 foreach id $misc(columns) {
1175 $widgets(listbox$id) activate $index
1181 if {[llength $args] != 1} {
1182 error "wrong \# of args: should be $w bbox index"
1184 # get a real index. This will adjust @x,y indicies
1185 # to account for the label, if any.
1186 set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1188 set id [lindex $misc(columns) 0]
1190 # we can get the x, y, and height from the first
1192 set bbox [$widgets(listbox$id) bbox $index]
1193 if {[string length $bbox] == 0} {return ""}
1195 foreach {x y w h} $bbox {}
1197 # the x and y coordinates have to be adjusted for the
1198 # fact that the listbox is inside a frame, and the
1199 # frame is inside a text widget. All of those add tiny
1201 incr y [winfo y $widgets(listbox$id)]
1202 incr y [winfo y $widgets(frame$id)]
1203 incr x [winfo x $widgets(listbox$id)]
1204 incr x [winfo x $widgets(frame$id)]
1206 # we can get the width by looking at the relative x
1207 # coordinate of the right edge of the last column
1208 set id [lindex $misc(columns) end]
1209 set w [expr {[winfo width $widgets(frame$id)] + \
1210 [winfo x $widgets(frame$id)]}]
1211 set bbox [list $x $y [expr {$x + $w}] $h]
1216 # we are just too clever for our own good. (that's a
1217 # polite way of saying this is more complex than it
1220 set id [lindex $args 0]
1221 set index [CheckColumnID $w $id]
1223 set args [lrange $args 1 end]
1224 if {[llength $args] == 0} {
1225 set result [bind $widgets(label$id)]
1228 # when we create a binding, we'll actually have the
1229 # binding run our own command with the user's command
1230 # as an argument. This way we can do some sanity checks
1231 # before running the command. So, when querying a binding
1232 # we need to only return the user's code
1233 set sequence [lindex $args 0]
1234 if {[llength $args] == 1} {
1235 set result [lindex [bind $widgets(label$id) $sequence] end]
1238 # replace %W with our toplevel frame, then
1240 set code [lindex $args 1]
1241 regsub -all {%W} $code $w code
1243 set result [bind $widgets(label$id) $sequence \
1244 [list ::mclistbox::LabelEvent $w $id $code]]
1250 eval ::mclistbox::Column-add {$w} $args
1257 set index [CheckColumnID $w $id]
1259 # remove the reference from our list of columns
1260 set misc(columns) [lreplace $misc(columns) $index $index]
1263 destroy $widgets(frame$id)
1265 # clear out references to the individual widgets
1266 unset widgets(frame$id)
1267 unset widgets(listbox$id)
1268 unset widgets(label$id)
1270 InvalidateScrollbars $w
1275 if {[llength $args] != 2} {
1276 error "wrong # of args: should be \"$w column cget name option\""
1278 set id [::mclistbox::Canonize $w column [lindex $args 0]]
1279 set option [lindex $args 1]
1280 set data [::mclistbox::Column-configure $w $id $option]
1281 set result [lindex $data 4]
1285 set id [::mclistbox::Canonize $w column [lindex $args 0]]
1286 set args [lrange $args 1 end]
1287 set result [eval ::mclistbox::Column-configure {$w} {$id} $args]
1291 if {[llength $args] != 0} {
1292 error "wrong # of args: should be \"$w column names\""
1294 set result $misc(columns)
1298 if {[llength $args] != 1} {
1299 error "wrong # of args: should be \"$w column nearest x\""
1302 set x [lindex $args 0]
1303 set tmp [$widgets(text) index @$x,0]
1304 set tmp [split $tmp "."]
1305 set index [lindex $tmp 1]
1307 set result [lindex $misc(columns) $index]
1311 if {[llength $args] != 1} {
1312 error "wrong # args: should be $w cget option"
1314 set opt [::mclistbox::Canonize $w option [lindex $args 0]]
1316 set result $options($opt)
1321 set result [eval ::mclistbox::Configure {$w} $args]
1326 set id [lindex $misc(columns) 0]
1327 set result [$widgets(listbox$id) curselection]
1331 if {[llength $args] < 1 || [llength $args] > 2} {
1332 error "wrong \# of args: should be $w delete first ?last?"
1335 # it's possible that the selection will change because
1336 # of something we do. So, grab the current selection before
1337 # we do anything. Just before returning we'll see if the
1338 # selection has changed. If so, we'll call our selectcommand
1339 if {$options(-selectcommand) != ""} {
1340 set col0 [lindex $misc(columns) 0]
1341 set priorSelection [$widgets(listbox$col0) curselection]
1344 set index1 [::mclistbox::MassageIndex $w [lindex $args 0]]
1345 if {[llength $args] == 2} {
1346 set index2 [::mclistbox::MassageIndex $w [lindex $args 1]]
1351 # note we do an eval here to make index2 "disappear" if it
1352 # is set to an empty string.
1353 foreach id $misc(columns) {
1354 eval {$widgets(listbox$id)} delete $index1 $index2
1356 eval {$widgets(hiddenListbox)} delete $index1 $index2
1358 InvalidateScrollbars $w
1364 if {[llength $args] < 1 || [llength $args] > 2} {
1365 error "wrong \# of args: should be $w get first ?last?"
1367 set index1 [::mclistbox::MassageIndex $w [lindex $args 0]]
1368 if {[llength $args] == 2} {
1369 set index2 [::mclistbox::MassageIndex $w [lindex $args 1]]
1374 set result [eval ::mclistbox::WidgetProc-get {$w} $index1 $index2]
1380 if {[llength $args] != 1} {
1381 error "wrong \# of args: should be $w index index"
1384 set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1385 set id [lindex $misc(columns) 0]
1387 set result [$widgets(listbox$id) index $index]
1391 if {[llength $args] < 1} {
1392 error "wrong \# of args: should be $w insert ?element \
1396 # it's possible that the selection will change because
1397 # of something we do. So, grab the current selection before
1398 # we do anything. Just before returning we'll see if the
1399 # selection has changed. If so, we'll call our selectcommand
1400 if {$options(-selectcommand) != ""} {
1401 set col0 [lindex $misc(columns) 0]
1402 set priorSelection [$widgets(listbox$col0) curselection]
1405 set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1407 ::mclistbox::Insert $w $index [lrange $args 1 end]
1409 InvalidateScrollbars $w
1414 if {[llength $args] != 1} {
1415 error "wrong \# of args: should be $w nearest y"
1418 # translate the y coordinate into listbox space
1419 set id [lindex $misc(columns) 0]
1420 set y [lindex $args 0]
1421 incr y -[winfo y $widgets(listbox$id)]
1422 incr y -[winfo y $widgets(frame$id)]
1424 set col0 [lindex $misc(columns) 0]
1426 set result [$widgets(listbox$col0) nearest $y]
1430 foreach {subcommand x y} $args {}
1431 switch $subcommand {
1433 # we have to treat scrolling in x and y differently;
1434 # scrolling in the y direction affects listboxes and
1435 # scrolling in the x direction affects the text widget.
1436 # to facilitate that, we need to keep a local copy
1438 set misc(scanmarkx) $x
1439 set misc(scanmarky) $y
1441 # set the scan mark for each column
1442 foreach id $misc(columns) {
1443 $widgets(listbox$id) scan mark $x $y
1446 # we can't use the x coordinate given us, since it
1447 # is relative to whatever column we are over. So,
1448 # we'll just usr the results of [winfo pointerx].
1449 $widgets(text) scan mark [winfo pointerx $w] $y
1452 # we want the columns to only scan in the y direction,
1453 # so we'll force the x componant to remain constant
1454 foreach id $misc(columns) {
1455 $widgets(listbox$id) scan dragto $misc(scanmarkx) $y
1458 # since the scan mark of the text widget was based
1459 # on the pointer location, so must be the x
1460 # coordinate to the dragto command. And since we
1461 # want the text widget to only scan in the x
1462 # direction, the y componant will remain constant
1463 $widgets(text) scan dragto \
1464 [winfo pointerx $w] $misc(scanmarky)
1466 # make sure the scrollbars reflect the changes.
1467 InvalidateScrollbars $w
1475 if {[llength $args] != 1} {
1476 error "wrong \# of args: should be $w see index"
1478 set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1480 foreach id $misc(columns) {
1481 $widgets(listbox$id) see $index
1483 InvalidateScrollbars $w
1488 # it's possible that the selection will change because
1489 # of something we do. So, grab the current selection before
1490 # we do anything. Just before returning we'll see if the
1491 # selection has changed. If so, we'll call our selectcommand
1492 if {$options(-selectcommand) != ""} {
1493 set col0 [lindex $misc(columns) 0]
1494 set priorSelection [$widgets(listbox$col0) curselection]
1497 set subcommand [lindex $args 0]
1498 set args [lrange $args 1 end]
1500 set prefix "wrong \# of args: should be $w"
1501 switch $subcommand {
1503 if {[llength $args] != 1} {
1504 error "$prefix selection $subcommand index"
1506 set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1507 set id [lindex $misc(columns) 0]
1508 set result [$widgets(listbox$id) selection includes $index]
1512 switch [llength $args] {
1514 set index1 [::mclistbox::MassageIndex $w \
1519 set index1 [::mclistbox::MassageIndex $w \
1521 set index2 [::mclistbox::MassageIndex $w \
1525 error "$prefix selection clear first ?last?"
1529 if {$options(-exportselection)} {
1530 SelectionHandler $w own
1532 if {$index1 != ""} {
1533 foreach id $misc(columns) {
1534 eval {$widgets(listbox$id)} selection set \
1543 if {[llength $args] != 1} {
1544 error "$prefix selection $subcommand index"
1546 set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1548 if {$options(-exportselection)} {
1549 SelectionHandler $w own
1551 foreach id $misc(columns) {
1552 $widgets(listbox$id) selection anchor $index
1558 switch [llength $args] {
1560 set index1 [::mclistbox::MassageIndex $w \
1565 set index1 [::mclistbox::MassageIndex $w \
1567 set index2 [::mclistbox::MassageIndex $w \
1571 error "$prefix selection clear first ?last?"
1575 if {$options(-exportselection)} {
1576 SelectionHandler $w own
1578 foreach id $misc(columns) {
1579 eval {$widgets(listbox$id)} selection clear \
1588 set id [lindex $misc(columns) 0]
1589 set result [$widgets(listbox$id) size]
1593 # if the user has a selectcommand defined and the selection changed,
1594 # run the selectcommand
1595 if {[info exists priorSelection] && $options(-selectcommand) != ""} {
1596 set column [lindex $misc(columns) 0]
1597 set currentSelection [$widgets(listbox$column) curselection]
1598 if {[string compare $priorSelection $currentSelection] != 0} {
1599 # this logic keeps us from getting into some sort of
1600 # infinite loop of the selectcommand changes the selection
1601 # (not particularly well tested, but it seems like the
1602 # right thing to do...)
1603 if {![info exists misc(skipRecursiveCall)]} {
1604 set misc(skipRecursiveCall) 1
1605 uplevel \#0 $options(-selectcommand) $currentSelection
1606 catch {unset misc(skipRecursiveCall)}
1614 # ::mclistbox::WidgetProc-get --
1616 # Implements the "get" widget command
1621 # args additional arguments to the get command
1623 proc ::mclistbox::WidgetProc-get {w args} {
1624 upvar ::mclistbox::${w}::widgets widgets
1625 upvar ::mclistbox::${w}::options options
1626 upvar ::mclistbox::${w}::misc misc
1628 set returnType "list"
1629 # the listbox "get" command returns different things
1630 # depending on whether it has one or two args. Internally
1631 # we *always* want a valid list, so we'll force a second
1632 # arg which in turn forces the listbox to return a list,
1633 # even if its a list of one element
1634 if {[llength $args] == 1} {
1635 lappend args [lindex $args 0]
1636 set returnType "listOfLists"
1639 # get all the data from each column
1640 foreach id $misc(columns) {
1641 set data($id) [eval {$widgets(listbox$id)} get $args]
1644 # now join the data together one row at a time. Ugh.
1646 set rows [llength $data($id)]
1647 for {set i 0} {$i < $rows} {incr i} {
1649 foreach column $misc(columns) {
1650 lappend this [lindex $data($column) $i]
1652 lappend result $this
1655 # now to unroll the list if necessary. If the user gave
1656 # us only one indicie we want to return a single list
1657 # of values. If they gave use two indicies we want to return
1659 if {[string compare $returnType "list"] == 0} {
1662 return [lindex $result 0]
1666 # ::mclistbox::CheckColumnID --
1668 # returns the index of the id within our list of columns, or
1669 # reports an error if the id is invalid
1678 # Will compute and return the index of the column within the
1679 # list of columns (which happens to be it's -position, as it
1680 # turns out) or returns an error if the named column doesn't
1683 proc ::mclistbox::CheckColumnID {w id} {
1684 upvar ::mclistbox::${w}::misc misc
1686 set id [::mclistbox::Canonize $w column $id]
1687 set index [lsearch -exact $misc(columns) $id]
1691 # ::mclistbox::LabelEvent --
1693 # Handle user events on the column labels for the Mclistbox
1699 # id a column identifier
1700 # code tcl code to be evaluated.
1704 # Executes the code associate with an event, but only if the
1705 # event wouldn't otherwise potentially trigger a resize event.
1707 # We use the cursor of the label to let us know whether the
1708 # code should be executed. If it is set to the cursor of the
1709 # mclistbox widget, the code will be executed. It is assumed
1710 # that if it is not the same cursor, it is the resize cursor
1711 # which should only be set if the cursor is very near a border
1712 # of a label and the column is resizable.
1714 proc ::mclistbox::LabelEvent {w id code} {
1715 upvar ::mclistbox::${w}::widgets widgets
1716 upvar ::mclistbox::${w}::options options
1718 # only fire the binding if the cursor is our default cursor
1719 # (ie: if we aren't in a "resize zone")
1720 set cursor [$widgets(label$id) cget -cursor]
1721 if {[string compare $cursor $options(-cursor)] == 0} {
1726 # ::mclistbox::HumanizeList --
1728 # Returns a human-readable form of a list by separating items
1729 # by columns, but separating the last two elements with "or"
1730 # (eg: foo, bar or baz)
1734 # list a valid tcl list
1738 # A string which as all of the elements joined with ", " or
1741 proc ::mclistbox::HumanizeList {list} {
1743 if {[llength $list] == 1} {
1744 return [lindex $list 0]
1746 set list [lsort $list]
1747 set secondToLast [expr {[llength $list] -2}]
1748 set most [lrange $list 0 $secondToLast]
1749 set last [lindex $list end]
1751 return "[join $most {, }] or $last"
1755 # ::mclistbox::Canonize --
1757 # takes a (possibly abbreviated) option or command name and either
1758 # returns the canonical name or an error
1763 # object type of object to canonize; must be one of "command",
1764 # "option", "column" or "column option".
1765 # opt the option (or command) to be canonized
1769 # Returns either the canonical form of an option or command,
1770 # or raises an error if the option or command is unknown or
1773 proc ::mclistbox::Canonize {w object opt} {
1774 variable widgetOptions
1775 variable columnOptions
1776 variable widgetCommands
1777 variable columnCommands
1778 variable labelCommands
1782 if {[lsearch -exact $widgetCommands $opt] >= 0} {
1786 # command names aren't stored in an array, and there
1787 # isn't a way to get all the matches in a list, so
1788 # we'll stuff the columns in a temporary array so
1789 # we can use [array names]
1790 set list $widgetCommands
1791 foreach element $list {
1792 set tmp($element) ""
1794 set matches [array names tmp ${opt}*]
1798 if {[lsearch -exact $labelCommands $opt] >= 0} {
1802 # command names aren't stored in an array, and there
1803 # isn't a way to get all the matches in a list, so
1804 # we'll stuff the columns in a temporary array so
1805 # we can use [array names]
1806 set list $labelCommands
1807 foreach element $list {
1808 set tmp($element) ""
1810 set matches [array names tmp ${opt}*]
1814 if {[lsearch -exact $columnCommands $opt] >= 0} {
1818 # command names aren't stored in an array, and there
1819 # isn't a way to get all the matches in a list, so
1820 # we'll stuff the columns in a temporary array so
1821 # we can use [array names]
1822 set list $columnCommands
1823 foreach element $list {
1824 set tmp($element) ""
1826 set matches [array names tmp ${opt}*]
1830 if {[info exists widgetOptions($opt)] \
1831 && [llength $widgetOptions($opt)] == 3} {
1834 set list [array names widgetOptions]
1835 set matches [array names widgetOptions ${opt}*]
1839 if {[info exists columnOptions($opt)]} {
1842 set list [array names columnOptions]
1843 set matches [array names columnOptions ${opt}*]
1847 upvar ::mclistbox::${w}::misc misc
1849 if {[lsearch -exact $misc(columns) $opt] != -1} {
1853 # column names aren't stored in an array, and there
1854 # isn't a way to get all the matches in a list, so
1855 # we'll stuff the columns in a temporary array so
1856 # we can use [array names]
1857 set list $misc(columns)
1858 foreach element $misc(columns) {
1859 set tmp($element) ""
1861 set matches [array names tmp ${opt}*]
1864 if {[llength $matches] == 0} {
1865 set choices [HumanizeList $list]
1866 error "unknown $object \"$opt\"; must be one of $choices"
1868 } elseif {[llength $matches] == 1} {
1869 # deal with option aliases
1870 set opt [lindex $matches 0]
1873 if {[llength $widgetOptions($opt)] == 1} {
1874 set opt $widgetOptions($opt)
1879 if {[llength $columnOptions($opt)] == 1} {
1880 set opt $columnOptions($opt)
1888 set choices [HumanizeList $list]
1889 error "ambiguous $object \"$opt\"; must be one of $choices"
1893 # ::mclistbox::Configure --
1895 # Implements the "configure" widget subcommand
1900 # args zero or more option/value pairs (or a single option)
1904 # Performs typcial "configure" type requests on the widget
1906 proc ::mclistbox::Configure {w args} {
1907 variable widgetOptions
1909 upvar ::mclistbox::${w}::widgets widgets
1910 upvar ::mclistbox::${w}::options options
1911 upvar ::mclistbox::${w}::misc misc
1913 if {[llength $args] == 0} {
1914 # hmmm. User must be wanting all configuration information
1915 # note that if the value of an array element is of length
1916 # one it is an alias, which needs to be handled slightly
1919 foreach opt [lsort [array names widgetOptions]] {
1920 if {[llength $widgetOptions($opt)] == 1} {
1921 set alias $widgetOptions($opt)
1922 set optName $widgetOptions($alias)
1923 lappend results [list $opt $optName]
1925 set optName [lindex $widgetOptions($opt) 0]
1926 set optClass [lindex $widgetOptions($opt) 1]
1927 set default [option get $w $optName $optClass]
1928 lappend results [list $opt $optName $optClass \
1929 $default $options($opt)]
1936 # one argument means we are looking for configuration
1937 # information on a single option
1938 if {[llength $args] == 1} {
1939 set opt [::mclistbox::Canonize $w option [lindex $args 0]]
1941 set optName [lindex $widgetOptions($opt) 0]
1942 set optClass [lindex $widgetOptions($opt) 1]
1943 set default [option get $w $optName $optClass]
1944 set results [list $opt $optName $optClass \
1945 $default $options($opt)]
1949 # if we have an odd number of values, bail.
1950 if {[expr {[llength $args]%2}] == 1} {
1951 # hmmm. An odd number of elements in args
1952 error "value for \"[lindex $args end]\" missing"
1955 # Great. An even number of options. Let's make sure they
1956 # are all valid before we do anything. Note that Canonize
1957 # will generate an error if it finds a bogus option; otherwise
1958 # it returns the canonical option name
1959 foreach {name value} $args {
1960 set name [::mclistbox::Canonize $w option $name]
1961 set opts($name) $value
1964 # process all of the configuration options
1965 foreach option [array names opts] {
1967 set newValue $opts($option)
1968 if {[info exists options($option)]} {
1969 set oldValue $options($option)
1970 # set options($option) $newValue
1976 SelectionHandler $w own
1977 set options($option) 1
1979 set options($option) 0
1984 # if the fill column changed, we need to adjust
1987 set options($option) $newValue
1991 $widgets(frame) configure -takefocus $newValue
1992 set options($option) [$widgets(frame) cget $option]
1996 foreach id $misc(columns) {
1997 $widgets(listbox$id) configure -background $newValue
1998 $widgets(frame$id) configure -background $newValue
2000 $widgets(frame) configure -background $newValue
2002 $widgets(text) configure -background $newValue
2003 set options($option) [$widgets(frame) cget $option]
2006 # { the following all must be applied to each listbox }
2009 -selectborderwidth -
2013 foreach id $misc(columns) {
2014 $widgets(listbox$id) configure $option $newValue
2016 $widgets(hiddenListbox) configure $option $newValue
2017 set options($option) [$widgets(hiddenListbox) cget $option]
2020 # { the following all must be applied to each listbox and frame }
2022 foreach id $misc(columns) {
2023 $widgets(listbox$id) configure $option $newValue
2024 $widgets(frame$id) configure -cursor $newValue
2027 # -cursor also needs to be applied to the
2028 # frames of each column
2029 foreach id $misc(columns) {
2030 $widgets(frame$id) configure -cursor $newValue
2033 $widgets(hiddenListbox) configure $option $newValue
2034 set options($option) [$widgets(hiddenListbox) cget $option]
2037 # { this just requires to pack or unpack the labels }
2041 foreach id $misc(columns) {
2042 pack $widgets(label$id) \
2043 -side top -fill x -expand n \
2044 -before $widgets(listbox$id)
2046 pack $widgets(hiddenLabel) \
2047 -side top -fill x -expand n \
2048 -before $widgets(hiddenListbox)
2052 foreach id $misc(columns) {
2053 pack forget $widgets(label$id)
2055 pack forget $widgets(hiddenLabel)
2057 set options($option) $newValue
2061 $widgets(hiddenListbox) configure -height $newValue
2062 InvalidateScrollbars $w
2063 set options($option) [$widgets(hiddenListbox) cget $option]
2067 if {$newValue == 0} {
2068 error "a -width of zero is not supported. "
2071 $widgets(hiddenListbox) configure -width $newValue
2072 InvalidateScrollbars $w
2073 set options($option) [$widgets(hiddenListbox) cget $option]
2076 # { the following all must be applied to each column frame }
2077 -columnborderwidth -
2079 regsub {column} $option {} listboxoption
2080 foreach id $misc(columns) {
2081 $widgets(listbox$id) configure $listboxoption $newValue
2083 $widgets(hiddenListbox) configure $listboxoption $newValue
2084 set options($option) [$widgets(hiddenListbox) cget \
2090 set options($option) 1
2092 set options($option) 0
2096 # { the following all must be applied to each column header }
2105 regsub {label} $option {} labeloption
2106 foreach id $misc(columns) {
2107 $widgets(label$id) configure $labeloption $newValue
2109 $widgets(hiddenLabel) configure $labeloption $newValue
2110 set options($option) [$widgets(hiddenLabel) cget $labeloption]
2113 # { the following apply only to the topmost frame}
2115 -highlightthickness -
2117 -highlightbackground -
2119 $widgets(frame) configure $option $newValue
2120 set options($option) [$widgets(frame) cget $option]
2124 set options($option) $newValue
2128 set options($option) $newValue
2132 InvalidateScrollbars $w
2133 set options($option) $newValue
2137 InvalidateScrollbars $w
2138 set options($option) $newValue
2144 # ::mclistbox::UpdateScrollbars --
2146 # This proc does the work of actually update the scrollbars to
2147 # reflect the current view
2155 # Potentially changes the size or placement of the scrollbars
2156 # (if any) based on changes to the widget
2158 proc ::mclistbox::UpdateScrollbars {w} {
2159 upvar ::mclistbox::${w}::widgets widgets
2160 upvar ::mclistbox::${w}::options options
2161 upvar ::mclistbox::${w}::misc misc
2163 if {![winfo ismapped $w]} {
2164 catch {unset misc(afterid)}
2169 if {[llength $misc(columns)] > 0} {
2170 if {[string length $options(-yscrollcommand)] != 0} {
2171 set col0 [lindex $misc(columns) 0]
2172 set yview [$widgets(listbox$col0) yview]
2173 eval $options(-yscrollcommand) $yview
2176 if {[string length $options(-xscrollcommand)] != 0} {
2177 set col0 [lindex $misc(columns) 0]
2178 set xview [$widgets(text) xview]
2179 eval $options(-xscrollcommand) $xview
2182 catch {unset misc(afterid)}
2185 # ::mclistbox::InvalidateScrollbars --
2187 # Schedules the scrollbars to be updated the next time
2196 # sets up a proc to be run in the idle event handler
2198 proc ::mclistbox::InvalidateScrollbars {w} {
2200 upvar ::mclistbox::${w}::widgets widgets
2201 upvar ::mclistbox::${w}::options options
2202 upvar ::mclistbox::${w}::misc misc
2204 if {![info exists misc(afterid)]} {
2206 [after idle "catch {::mclistbox::UpdateScrollbars $w}"]
2210 # ::mclistbox::Insert --
2212 # This implements the "insert" widget command; it arranges for
2213 # one or more elements to be inserted into the listbox.
2218 # index a valid listbox index to designate where the data is
2220 # arglist A list of values to be inserted. Each element of the
2221 # list will itself be treated as a list, one element for
2226 # Inserts the data into the list and updates the scrollbars
2228 proc ::mclistbox::Insert {w index arglist} {
2230 upvar ::mclistbox::${w}::widgets widgets
2231 upvar ::mclistbox::${w}::options options
2232 upvar ::mclistbox::${w}::misc misc
2234 foreach list $arglist {
2235 # make sure we have enough elements for each column
2236 for {set i [llength $list]} {$i < [llength $misc(columns)]} {incr i} {
2241 foreach id $misc(columns) {
2242 $widgets(listbox$id) insert $index [lindex $list $column]
2246 # we also want to add a bogus item to the hidden listbox. Why?
2247 # For standard listboxes, if you specify a height of zero the
2248 # listbox will resize to be just big enough to hold all the lines.
2249 # Since we use a hidden listbox to regulate the size of the widget
2250 # and we want this same behavior, this listbox needs the same number
2251 # of elements as the visible listboxes
2253 # (NB: we might want to make this listbox contain the contents
2254 # of all columns as a properly formatted list; then the get
2255 # command can query this listbox instead of having to query
2256 # each individual listbox. The disadvantage is that it doubles
2257 # the memory required to hold all the data)
2258 $widgets(hiddenListbox) insert $index "x"
2263 # ::mclistbox::ColumnIsHidden --
2265 # Returns a boolean representing whether a column is visible or
2271 # id a column identifier
2275 # returns 1 if the column is visible (ie: not hidden), or 0
2276 # if invisible. Note that the result doesn't consider whether
2277 # the column is actually viewable. Even if it has been scrolled
2278 # off screen, 1 will be returned as long as the column hasn't
2279 # been hidden by turning the visibility off.
2281 proc ::mclistbox::ColumnIsHidden {w id} {
2282 upvar ::mclistbox::${w}::widgets widgets
2283 upvar ::mclistbox::${w}::misc misc
2286 set col [lsearch -exact $misc(columns) $id]
2291 set window [$widgets(text) window cget $index -window]
2292 if {[string length $window] > 0 && [winfo exists $window]} {
2300 # ::mclistbox::AdjustColumns --
2302 # Adjusts the height and width of the individual columns.
2307 # height height, in pixels, that the columns should be adjusted
2308 # to. If null, the height will be the height of the text
2309 # widget that underlies our columns.
2313 # All columns will be adjusted to fill the text widget in the y
2314 # direction. Also, if a -fillcolumn is defined, that column will
2315 # be grown, if necessary, to fill the widget in the x direction.
2317 proc ::mclistbox::AdjustColumns {w {height ""}} {
2318 upvar ::mclistbox::${w}::widgets widgets
2319 upvar ::mclistbox::${w}::options options
2320 upvar ::mclistbox::${w}::misc misc
2322 if {[string length $height] == 0} {
2323 set height [winfo height $widgets(text)]
2326 # resize the height of each column so it matches the height
2327 # of the text widget, minus a few pixels.
2329 foreach id $misc(columns) {
2330 $widgets(frame$id) configure -height $height
2333 # if we have a fillcolumn, change its width accordingly
2334 if {$options(-fillcolumn) != ""} {
2336 # make sure the column has been defined. If not, bail (?)
2337 if {![info exists widgets(frame$options(-fillcolumn))]} {
2340 set frame $widgets(frame$options(-fillcolumn))
2341 set minwidth $misc(min-$frame)
2343 # compute current width of all columns
2346 foreach id $misc(columns) {
2347 if {![ColumnIsHidden $w $id] && $id != $options(-fillcolumn)} {
2348 incr colwidth [winfo reqwidth $widgets(frame$id)]
2352 # this is just shorthand for later use...
2353 set id $options(-fillcolumn)
2355 # compute optimal width
2356 set optwidth [expr {[winfo width $widgets(text)] - \
2357 (2 * [$widgets(text) cget -padx])}]
2359 # compute the width of our fill column
2360 set newwidth [expr {$optwidth - $colwidth}]
2362 if {$newwidth < $minwidth} {
2363 set newwidth $minwidth
2366 # adjust the width of our fill column frame
2367 $widgets(frame$id) configure -width $newwidth
2370 InvalidateScrollbars $w
2373 # ::mclistbox::FindResizableNeighbor --
2375 # Returns the nearest resizable column to the left or right
2376 # of the named column.
2381 # id column identifier
2382 # direction should be one of "right" or "left". Actually, anything
2383 # that doesn't match "right" will be treated as "left"
2387 # Will return the column identifier of the nearest resizable
2388 # column, or an empty string if none exists.
2390 proc ::mclistbox::FindResizableNeighbor {w id {direction right}} {
2391 upvar ::mclistbox::${w}::widgets widgets
2392 upvar ::mclistbox::${w}::options options
2393 upvar ::mclistbox::${w}::misc misc
2396 if {$direction == "right"} {
2398 set stop [llength $misc(columns)]
2399 set start [expr {[lsearch -exact $misc(columns) $id] + 1}]
2403 set start [expr {[lsearch -exact $misc(columns) $id] - 1}]
2406 for {set i $start} {$i != $stop} {incr i $incr} {
2407 set col [lindex $misc(columns) $i]
2408 if {![ColumnIsHidden $w $col] && $options($col:-resizable)} {
2415 # ::mclistbox::ResizeEvent --
2417 # Handles the events which implement interactive column resizing
2423 # type type of event; must be one of "buttonpress", "drag",
2424 # "motion", or "buttonrelease"
2425 # widget the actual widget that the event occured over
2426 # x the x coordinate of the mouse, relative to $widget
2427 # X the root x coordinate of the mouse
2428 # Y the root y coordinate of the mouse
2430 # The basic idea is this:
2432 # whenever the cursor moves over the label, we examine it's x
2433 # coordinate to determine if its within a fixed amount of
2434 # pixels from the left or right edge. If it is, we reconfigure
2435 # the cursor to be a suitable "this thing is resizable" cursor.
2437 # On a buttonclick, if the cursor is not the default cursor
2438 # (and thus, presumably the resize cursor), we set up some
2439 # state for an eventual resize. We figure out which columns
2440 # are to the left and right and base a maximum resize amount
2441 # for each direction. We also define the absolute X coordinate
2442 # of the buttonpress as a reference point for the drag.
2444 # on a b1-motion, if the drag state exists, we look at the
2445 # absolute X value and use it to compute a delta value from
2446 # the reference (the X of the button press). We then resize the
2447 # left and right column frames by the delta amount.
2449 # on a button release, we unset the state and the cursor, which
2450 # cancels all of the above.
2452 proc ::mclistbox::ResizeEvent {w type widget x X Y} {
2454 upvar ::mclistbox::${w}::widgets widgets
2455 upvar ::mclistbox::${w}::options options
2456 upvar ::mclistbox::${w}::misc misc
2457 upvar ::mclistbox::${w}::columnID columnID
2459 # if the widget doesn't allow resizable cursors, there's
2460 # nothing here to do...
2461 if {!$options(-resizablecolumns)} {
2465 # this lets us keep track of some internal state while
2466 # the user is dragging the mouse
2469 # this lets us define a small window around the edges of
2471 set threshold [expr {$options(-labelborderwidth) + 4}]
2473 # this is what we use for the "this is resizable" cursor
2474 set resizeCursor sb_h_double_arrow
2476 # if we aren't over an area that we care about, bail.
2477 if {![info exists columnID($widget)]} {
2481 # id refers to the column name
2482 set id $columnID($widget)
2487 # we will do all the work of initiating a drag only if
2488 # the cursor is not the defined cursor. In theory this
2489 # will only be the case if the mouse moves over the area
2490 # in which a drag can happen.
2491 if {[$widgets(label$id) cget -cursor] == $resizeCursor} {
2492 if {$x <= $threshold} {
2493 set lid [::mclistbox::FindResizableNeighbor $w $id left]
2494 if {$lid == ""} return
2495 set drag(leftFrame) $widgets(frame$lid)
2496 set drag(rightFrame) $widgets(frame$id)
2498 set drag(leftListbox) $widgets(listbox$lid)
2499 set drag(rightListbox) $widgets(listbox$id)
2502 set rid [::mclistbox::FindResizableNeighbor $w $id right]
2503 if {$rid == ""} return
2504 set drag(leftFrame) $widgets(frame$id)
2505 set drag(rightFrame) $widgets(frame$rid)
2507 set drag(leftListbox) $widgets(listbox$id)
2508 set drag(rightListbox) $widgets(listbox$rid)
2513 set drag(leftWidth) [winfo width $drag(leftFrame)]
2514 set drag(rightWidth) [winfo width $drag(rightFrame)]
2516 # it seems to be a fact that windows can never be
2517 # less than one pixel wide. So subtract that one pixel
2518 # from our max deltas...
2519 set drag(maxDelta) [expr {$drag(rightWidth) - 1}]
2520 set drag(minDelta) -[expr {$drag(leftWidth) - 1}]
2527 if {[info exists drag(x)]} {return}
2529 # this is just waaaaay too much work for a motion
2534 # is the column the user is over resizable?
2535 if {!$options($id:-resizable)} {return}
2537 # did the user click on the left of a column?
2538 if {$x < $threshold} {
2539 set leftColumn [::mclistbox::FindResizableNeighbor $w $id left]
2540 if {$leftColumn != ""} {
2544 } elseif {$x > [winfo width $widget] - $threshold} {
2545 set rightColumn [::mclistbox::FindResizableNeighbor $w $id \
2547 if {$rightColumn != ""} {
2552 # if it's resizable, change the cursor
2553 set cursor [$widgets(label$id) cget -cursor]
2554 if {$resizable && $cursor != $resizeCursor} {
2555 $widgets(label$id) configure -cursor $resizeCursor
2557 } elseif {!$resizable && $cursor == $resizeCursor} {
2558 $widgets(label$id) configure -cursor $options(-cursor)
2563 # if the state is set up, do the drag...
2564 if {[info exists drag(x)]} {
2566 set delta [expr {$X - $drag(x)}]
2567 if {$delta >= $drag(maxDelta)} {
2568 set delta $drag(maxDelta)
2570 } elseif {$delta <= $drag(minDelta)} {
2571 set delta $drag(minDelta)
2574 set lwidth [expr {$drag(leftWidth) + $delta}]
2575 set rwidth [expr {$drag(rightWidth) - $delta}]
2577 $drag(leftFrame) configure -width $lwidth
2578 $drag(rightFrame) configure -width $rwidth
2584 set fillColumnID $options(-fillcolumn)
2585 if {[info exists drag(x)] && $fillColumnID != {}} {
2586 set fillColumnFrame $widgets(frame$fillColumnID)
2587 if {[string compare $drag(leftFrame) $fillColumnFrame] == 0 \
2588 || [string compare $drag(rightFrame) $fillColumnFrame] == 0} {
2589 set width [$fillColumnFrame cget -width]
2590 set misc(minFillColumnSize) $width
2592 set misc(min-$drag(leftFrame)) [$drag(leftFrame) cget -width]
2593 set misc(min-$drag(rightFrame)) [$drag(rightFrame) cget -width]
2596 # reset the state and the cursor
2598 $widgets(label$id) configure -cursor $options(-cursor)
2604 # end of mclistbox.tcl